这对我有用(只需根据列索引数组复制每一列):
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