我正在嘗試將 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
uj5u.com熱心網友回復：
這對我有用（只需根??據列索引陣列復制每一列）：
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
uj5u.com熱心網友回復：
我認為這接近 OP 想要的。我沒有費心保存檔案，因為它與我的測驗無關，我添加了列標題。
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
注意：回圈遍歷值幾乎總是比復制范圍快得多。
附錄
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
結束子
結果
我很著急。這就是復制標題和過濾資料所需的全部內容：
tCopyTable.ListColumns(OriginalColumnOrder(c)).Range.Copy .Rows(1).Columns(NewColumnOrder(c))
如果您只想使用資料：
tCopyTable.ListColumns(OriginalColumnOrder(c)).DataBodyRange.Copy .Rows(1).Columns(NewColumnOrder(c))
轉載請註明出處，本文鏈接：https://www.uj5u.com/shujuku/434845.html
上一篇：如何在用戶定義的VBA函式中從另一個作業表中提取資料
下一篇：IsDate函式無法識別日期