Excel VBA 不复制所有列的高级过滤器

Question

我在 VBA 中第一次使用 AdvancedFilter。我正在尝试仅将特定列从源数据 table 复制到外部工作簿 table。我已经看到在 VBA 中不这样做时应该如何指定它，但它在我的代码中不起作用。

目前，过滤有效，它正在复制到外部工作簿 table，但它正在复制所有标题和过滤后的数据，并将所有内容粘贴到外部工作簿 table，而不仅仅是要复制的列在我的外部 table.

代码运行时没有任何错误消息。

所以我想要的结果是

因为它不复制源数据（SDCRange）标题
仅复制外部 table 中的列 (copyToRng)

当前代码：

Sub StockManagement(wb As Workbook, ws As Worksheet)
Dim TemplPath As String
Dim SMTemp As String
Dim SMTempF As String  

'Create Filter Criteria ranges
With MainWB.Worksheets.Add
    .Name = "FltrCrit"
    Dim FltrCrit As Worksheet
    Set FltrCrit = MainWB.Worksheets("FltrCrit")
End With

With FltrCrit
    Dim DerangedCrit As Range
    Dim myLastColumn As Long

    'Create Deranged Filter Criteria Range
    .Cells(1, "A") = "Deranged"
    .Cells(2, "A") = "MS"
    .Cells(3, "A") = "<>4"
    .Cells(2, "B") = "SOH"
    .Cells(3, "B") = "=0"

    'get last column, set range name
    With .Cells

        'find last column of data cell range
        myLastColumn = .Find(What:="*", After:=.Cells(2), LookIn:=xlFormulas, LookAt:=xlPart, SearchOrder:=xlByColumns, SearchDirection:=xlNext).Column

        'specify cell range
        Set DerangedCrit = .Range(.Cells(2, "A:A"), .Cells(3, myLastColumn))

    End With


'Copy Filtered data to specified tables
Dim tblSDC As ListObject, tblFiltered As ListObject
Dim shSDC As Worksheet, shFiltered As Worksheet
Dim critRange As Range, copyToRng As Range, SDCRange As Range

'Assign values to sheet variables
Set shSDC = MainWB.Worksheets(2)
Set shFiltered = wb.Worksheets("Deranged with SOH")

'Turn off autofilter on filtered tab
shFiltered.AutoFilterMode = False

'Store Filtered table in variable
Set tblFiltered = shFiltered.ListObjects("Table_Deranged_with_SOH")
Set tblSDC = shSDC.ListObjects("Table_SDCdata")

'Remove Filtered table Filters
tblFiltered.AutoFilter.ShowAllData

'Set Criteria range to variable
Set critRange = DerangedCrit

'Set Copy to range on Filtered sheet table
Set copyToRng = tblFiltered.DataBodyRange(1, 1)
Set SDCRange = tblSDC.Range

'Use Advanced Filter
SDCRange.CurrentRegion.AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=critRange, CopyToRange:=copyToRng, Unique:=False

任何帮助将不胜感激。

编辑：

如果我将 external/output 范围设置为

Set copyToRng = tblFiltered.HeaderRowRange

对我来说，它的行为方式与不使用 VBA 时使用高级过滤器的方式相同。因此，您将输出 table 范围设置为输出 table 范围 headers，然后应该只复制所有匹配的列。但是当我这样做时，没有任何内容被复制，output/external table 是空的。

所以任何建议都会有所帮助，谢谢。

Answer 1

未经测试但应该让您走上正轨：

Sub StockManagement(wb As Workbook, ws As Worksheet)

    Dim FltrCrit As Worksheet
    Dim DerangedCrit As Range
    Dim tblSDC As ListObject, tblFiltered As ListObject
    Dim m As Variant, c As Range


    Set FltrCrit = MainWB.Worksheets.Add()
    With FltrCrit
        .Name = "FltrCrit"
        .Cells(1, "A") = "Deranged"
        .Cells(2, "A") = "MS"
        .Cells(3, "A") = "<>4"
        .Cells(2, "B") = "SOH"
        .Cells(3, "B") = "=0"
        Set DerangedCrit = .Range(.Cells(2, "A"), _
                                  .Cells(2, .Columns.Count).End(xlToLeft)).Resize(2)
    End With

    Set tblFiltered = wb.Worksheets("Deranged with SOH").ListObjects("Table_Deranged_with_SOH")
    tblFiltered.AutoFilter.ShowAllData

    Set tblSDC = MainWB.Worksheets(2).ListObjects("Table_SDCdata")
    tblSDC.Range.AdvancedFilter Action:=xlFilterInPlace, CriteriaRange:=DerangedCrit

    'loop over the headers in the destination table
    For Each c In tblFiltered.HeaderRowRange.Cells
        m = Application.Match(c.Value, tblSDC.HeaderRowRange, 0) 'matched source header?
        If Not IsError(m) Then
            'got a match - copy visible cells for this column
            tblSDC.ListColumns(c.Value).DataBodyRange.SpecialCells(xlCellTypeVisible).Copy _
                    c.Offset(1, 0)
        End If
    Next c

End Sub

Answer 2

谜团解开了，这是一个愚蠢的错误。代码工作得很好，external/output table 为空的问题是因为 external/output table 中我的 headers 有一个额外的 space 中，所以无法匹配到源数据 headers.

我确实稍微调整了代码以删除上面的一些变量（如@Tim Williams 所建议的）。

代码现在看起来像这样：

Sub StockManagement(wb As Workbook, ws As Worksheet)
Dim TemplPath As String
Dim SMTemp As String
Dim SMTempF As String  

'Create Filter Criteria ranges
With MainWB.Worksheets.Add
    .Name = "FltrCrit"
    Dim FltrCrit As Worksheet
    Set FltrCrit = MainWB.Worksheets("FltrCrit")
End With

With FltrCrit
    Dim DerangedCrit As Range
    Dim myLastColumn As Long

    'Create Deranged Filter Criteria Range
    .Cells(1, "A") = "Deranged"
    .Cells(2, "A") = "MS"
    .Cells(3, "A") = "<>4"
    .Cells(2, "B") = "SOH"
    .Cells(3, "B") = "=0"

    'get last column, set range name
    With .Cells

        'find last column of data cell range
        myLastColumn = .Find(What:="*", After:=.Cells(2), LookIn:=xlFormulas, LookAt:=xlPart, SearchOrder:=xlByColumns, SearchDirection:=xlNext).Column

        'specify cell range
        Set DerangedCrit = .Range(.Cells(2, "A:A"), .Cells(3, myLastColumn))

    End With

'Copy Filtered data to specified tables
Dim tblFiltered As ListObject
Dim copyToRng As Range, SDCRange As Range

'Store Filtered table in variable
Set tblFiltered = wb.Worksheets("Deranged with SOH").ListObjects("Table_Deranged_with_SOH")

'Remove Filtered table Filters
tblFiltered.AutoFilter.ShowAllData

'Set Copy to range on Filtered sheet table
Set copyToRng = tblFiltered.HeaderRowRange
Set SDCRange = MainWB.Worksheets(2).ListObjects("Table_SDCdata").Range

'Use Advanced Filter
SDCRange.AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=DerangedCrit, CopyToRange:=copyToRng, Unique:=False

Excel VBA 不复制所有列的高级过滤器

Excel VBA Advanced Filter to not copy all columns

excel

vba

range

advanced-filter