excel - 复制可见单元格以将 listobject 过滤数据提取到新工作簿

Question

我正在尝试将 listobject 过滤数据提取到新工作簿。但是，会提取所有数据，而不仅仅是过滤后的数据。

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

Answer 1

这对我有用(只需根​​据列索引数组复制每一列):

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

编辑:一种不同的基于数组的方法 - 这更快，但又更复杂，所以有一个权衡。

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