I am trying to extract listobject filtered data to a new workbook. However, all data is extracted instead of just the filtered data. Not sure why this is happening.
Set loop_obj = wsCopy.ListObjects(1)
loop_obj.AutoFilter.ShowAllData
ColNum = Application.WorksheetFunction.Match("DateOrder", wsCopy.Rows(1), 0)
With loop_obj
.Range.AutoFilter Field:=ColNum, Criteria1:=">=0"
End With
'Add Copy Values to Array
Set loop_copy = loop_obj.AutoFilter.Range.SpecialCells(xlCellTypeVisible)
arr = loop_copy.CurrentRegion.Offset(1, 0)
aRws = Evaluate("Row(1:" & UBound(arr) & ")")
arr = Application.Index(arr, aRws, Array(1, 2, 3, 4, 5))
'Create New Workbook with a Blank Worksheet
wb.Worksheets.Add.Move
Set wb_new = ActiveWorkbook
Set wsDest = ActiveWorkbook.ActiveSheet
'Perform Paste Operations
Set loop_paste = wsDest.Range("A1")
loop_paste.Resize(UBound(arr, 1), UBound(arr, 2)).value = arr
With wsDest
.Range(Cells(1, DateNum), Cells(1200, DateNum)).NumberFormat = "[$-en-US]d-mmm-yy;@"
.Parent.SaveAs FileName:=dFilePath, FileFormat:=xlCSVUTF8
.Parent.Close True
End With
loop_obj.AutoFilter.ShowAllData
CodePudding user response：
This worked for me (just copy each column based off the array)
Sub tester()
Dim wsCopy As Worksheet, loop_copy As Range
Dim loop_obj As ListObject, colnum As Long
Dim col, visRows As Long, rngDest As Range, i As Long
Set wsCopy = Sheets("Details")
Set loop_obj = wsCopy.ListObjects(1)
loop_obj.AutoFilter.ShowAllData
colnum = Application.Match("DateOrder", loop_obj.HeaderRowRange, 0)
If IsError(colnum) Then
MsgBox "Header not found!"
Exit Sub
End If
Application.ScreenUpdating = False
loop_obj.Range.AutoFilter Field:=colnum, Criteria1:=">=0"
On Error Resume Next 'in case no visible rows to count
visRows = loop_obj.DataBodyRange.Columns(1).SpecialCells(xlCellTypeVisible).Count
On Error GoTo 0
If visRows > 0 Then
Set rngDest = Sheets("destination").Range("B2")
i = 0
For Each col In Array(1, 2, 3, 4, 5)
loop_obj.DataBodyRange.Columns(col).SpecialCells(xlCellTypeVisible).Copy
rngDest.Parent.Paste Destination:=rngDest.Offset(0, i)
i = i 1
Next col
End If
loop_obj.AutoFilter.ShowAllData
End Sub
EDIT: a different array-based approach
Sub Tester()
Dim wsCopy As Worksheet, loop_copy As Range
Dim loop_obj As ListObject, colnum As Long
Dim col, visRows As Long, rngDest As Range, i As Long, data
Set wsCopy = Sheets("Details")
Set loop_obj = wsCopy.ListObjects(1)
loop_obj.AutoFilter.ShowAllData
colnum = Application.Match("DateOrder", loop_obj.HeaderRowRange, 0)
If IsError(colnum) Then
MsgBox "Header not found!"
Exit Sub
End If
Application.ScreenUpdating = False
loop_obj.Range.AutoFilter Field:=colnum, Criteria1:=">=0"
data = arrayFromVisibleRows(loop_obj.DataBodyRange)
If Not IsEmpty(data) Then
With Sheets("Destination").Range("B2")
.CurrentRegion.ClearContents
.Resize(UBound(data, 1), UBound(data, 2)).Value = data
End With
End If
loop_obj.AutoFilter.ShowAllData
End Sub
'Return a 2D array using only visible row in `rng`
' Optionally include only column indexes in `cols` (passed as a 1D array)
Function arrayFromVisibleRows(rng As Range, Optional cols As Variant = Empty)
Dim rngVis As Range, data, dataOut
Dim rw As Long, col, e, c As Range, cOut As Long, rOut As Long, srcRow As Long
On Error Resume Next
Set rngVis = rng.Columns(1).SpecialCells(xlCellTypeVisible)
On Error GoTo 0
If Not rngVis Is Nothing Then
data = rng.Value 'read all the range data to an array
If IsEmpty(cols) Then
'create an array with all column indexes if none were provided
cols = Application.Transpose(Evaluate("=ROW(1:" & rng.Columns.Count & ")"))
End If
'size the output array
ReDim dataOut(1 To rngVis.Cells.Count, 1 To (UBound(cols) - LBound(cols)) 1)
rOut = 1
For Each c In rngVis.Cells
cOut = 1
srcRow = 1 (c.Row - rng.Cells(1).Row)
For Each col In cols 'loop the required columns
dataOut(rOut, cOut) = data(srcRow, col)
cOut = cOut 1
Next col
rOut = rOut 1
Next c
arrayFromVisibleRows = dataOut
Else
arrayFromVisibleRows = Empty
End If
End Function
CodePudding user response：
I think that this is close to what the OP wants. I didn't bother saving the file because its not relevant to my test and I added column headers.
Sub Main()
Dim tCopyTable As ListObject
Set tCopyTable = wsCopy.ListObjects(1)
Dim DateOrder As ListColumn
Dim Source As Range
With tCopyTable
If Not .AutoFilter Is Nothing Then .AutoFilter.ShowAllData
Set DateOrder = tCopyTable.ListColumns("DateOrder")
.Range.AutoFilter Field:=DateOrder.Index, Criteria1:=">=0"
Set Source = .Range.Offset(1)
End With
Dim CountOfVisibleDates As Long
CountOfVisibleDates = WorksheetFunction.Subtotal(103, Source.Columns(DateOrder.Index))
If CountOfVisibleDates > 0 Then
Dim wb As Workbook
Set wb = Workbooks.Add
With wb.Worksheets(1)
tCopyTable.HeaderRowRange.Resize(1, 5).Copy .Range("A1")
Source.Resize(, 5).Copy .Range("A2")
End With
End If
End Sub
Note: Looping through the values is almost always much faster than copying ranges.
Addendum
Sub Main2() Dim tCopyTable As ListObject Set tCopyTable = wsCopy.ListObjects(1) Dim DateOrder As ListColumn Dim Source As Range With tCopyTable If Not .AutoFilter Is Nothing Then .AutoFilter.ShowAllData Set DateOrder = tCopyTable.ListColumns("DateOrder") .Range.AutoFilter Field:=DateOrder.Index, Criteria1:=">=0" Set Source = .Range.Offset(1) End With
Dim CountOfVisibleDates As Long
CountOfVisibleDates = WorksheetFunction.Subtotal(103, Source.Columns(DateOrder.Index))
Dim OriginalColumnOrder As Variant
Dim NewColumnOrder As Variant
OriginalColumnOrder = Array(1, 2, 3, 4, 5)
NewColumnOrder = Array(3, 2, 1, 5, 4)
Dim c As Long
If CountOfVisibleDates > 0 Then
Dim wb As Workbook
Set wb = Workbooks.Add
With wb.Worksheets(1)
For c = 0 To UBound(NewColumnOrder)
tCopyTable.HeaderRowRange.Columns(OriginalColumnOrder(c)).Copy .Rows(1).Columns(NewColumnOrder(c))
Source.Resize(, 5).Columns(OriginalColumnOrder(c)).Copy .Rows(2).Columns(NewColumnOrder(c))
Next
End With
End If
End Sub
Result
I was in a rush. This is all that is needed to copy the headers and filtered data:
tCopyTable.ListColumns(OriginalColumnOrder(c)).Range.Copy .Rows(1).Columns(NewColumnOrder(c))
If you just want the data use:
tCopyTable.ListColumns(OriginalColumnOrder(c)).DataBodyRange.Copy .Rows(1).Columns(NewColumnOrder(c))