Copy visible cells to extract listobject filtered data to a new workbook

Viewed 147

I am trying to extract listobject filtered data to a new workbook. However, all data is extracted instead of just the filtered data.

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
2 Answers

This worked for me (just copy each column based off the array of column indexes):

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 - this is faster, but again it's more complex, so there's a trade-off.

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

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

Result Image

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))
Related