使用具有动态范围的自动过滤器

Question

仍在学习绳索，所以请耐心等待！我有一个每月数据转储，它将被复制到工作簿中，它始终采用相同的格式。我正在尝试编写一个宏，该宏使用工作簿中另一个工作表中的名称列表来过滤预设列中的数据。理想情况下，我希望能够从列表中添加或删除名称。过滤后，我希望它复制所有可见的单元格并将它们粘贴到新工作表中。

我开始使用自动过滤器，然后使用计数数组，但我收到一个错误并且它没有过滤。因为过滤器应用于工作表，但它似乎无法查找实际名称，并且只返回空白。 它似乎确实在我的动态列表中计算了正确的名称数量......所以我会接受。

所以示例数据： 工作表：名称

工作表：书籍

理想情况下，代码从“姓名”中的“人员”列中获取姓名列表，查看“姓名”列“书籍”，找到每个匹配项，然后将整行复制并转储到新工作表中。

这是我写东西的最佳尝试。

Sub FilterName()
Dim i As Long
Dim lastrow As Long
Dim arrSummary() As Variant

With ThisWorkbook.Sheets("Names")
  lastrow = .Cells(Rows.Count, "B").End(xlUp).Row
  ReDim arrSummary(1 To lastrow)

  For i = 1 To lastrow
  arrSummary(i) = .Cells(i, 1)
  Next

End With
For i = LBound(arrSummary) To UBound(arrSummary)
      With ThisWorkbook.Sheets("Books")
      .Range("F:F").AutoFilter Field:=1, Criteria1:=arrSummary(i), Operator:=xlFilterValues
      
    .ThisWorkbook.Sheets("Books").Range("A1:AA100000").SpecialCells(xlCellTypeVisible).Copy
    'Getting error 438 here
    .ThisWorkbook.Sheets("Loans").Paste
      End With
Next i

End Sub

我确实考虑过高级过滤器，但即使在 VBA 之外也无法使其工作，然后不想做查找路线，因为觉得它很笨重...不过愿意探索这些选项。

干杯:)

Answer 1

如果您有 Excel 365，您可以在没有 VBA 的情况下实现您的目标，但使用新的 FILTER 功能。

在我的示例中，我创建了两个表（插入 > 表），分别命名为 tblPeople 和 tblBooks。

这样公式就很容易阅读了：

关于你的代码：当你有很多数据时，这个过程会很慢。

一般来说，将数据读入数组时会获得更好的性能（就像你已经对人民表所做的那样），在数组中进行过滤，然后将数组写回工作表（你会发现很多SO上的示例。

顺便说一句：您可以像这样将范围读取到数组中： arrSummary = rg.value 其中rg 是您要读取的范围。

Answer 2

过滤器名称

• 它将标准工作表 (cws) 的B (cCol) 列中的值写入一个基于1 的二维一列数组(cData)。然后它将遍历数组中的值，并通过每个数组的值过滤 源工作表 (sws) 的第 6 列 (scCol) 并复制源范围的 (@987654327 @) 包含与目标工作表 (dws) 的第一个可用行匹配的单元格的行，从A (dfCol) 列开始。

Option Explicit

Sub FilterNames()
    
    ' Criteria
    Const cName As String = "Names"
    Const cCol As String = "B"
    Const cfRow As Long = 2
    ' Source
    Const sName As String = "Books"
    Const sCols As String = "A:AA"
    Const scCol As Long = 6 ' also used for AutoFilter's Field parameter
    Const sfRow As Long = 1
    ' Destination
    Const dName As String = "Loans"
    Const dfCol As String = "A"
    Const dfRow As Long = 2
    ' Workbook
    Dim wb As Workbook: Set wb = ThisWorkbook
    
    ' Criteria
    Dim cws As Worksheet: Set cws = wb.Worksheets(cName)
    Dim clRow As Long: clRow = cws.Cells(cws.Rows.Count, cCol).End(xlUp).Row
    If clRow < cfRow Then Exit Sub
    Dim crCount As Long: crCount = clRow - cfRow + 1
    Dim crg As Range: Set crg = cws.Cells(cfRow, cCol).Resize(crCount)
    Dim cData As Variant
    If crCount = 1 Then
        ReDim cData(1 To 1, 1 To 1): cData(1, 1) = crg.Value
    Else
        cData = crg.Value
    End If
    
    ' Source
    Dim sws As Worksheet: Set sws = wb.Worksheets(sName)
    Dim srg As Range: Set srg = sws.UsedRange.Columns(sCols)
    Dim sdrg As Range: Set sdrg = srg.Resize(srg.Rows.Count - 1).Offset(1)
    Dim sdcrg As Range: Set sdcrg = sdrg.Columns(scCol)
    
    ' Destination
    Dim dws As Worksheet: Set dws = wb.Worksheets(dName)
    Dim dlRow As Long: dlRow = dws.Cells(dws.Rows.Count, dfCol).End(xlUp).Row
    Dim dCell As Range
    If dlRow < dfRow Then
        Set dCell = dws.Cells(dfRow, dfCol)
    Else
        Set dCell = dws.Cells(dlRow, dfCol).Offset(1)
    End If
    
    Application.ScreenUpdating = False
    
    Dim drCount As Long
    Dim r As Long
    
    For r = 1 To UBound(cData, 1)
        sws.AutoFilterMode = False
        srg.AutoFilter scCol, CStr(cData(r, 1)), xlFilterValues
        drCount = Application.Subtotal(103, sdcrg)
        Debug.Print drCount, cData(r, 1)
        If drCount > 0 Then
            sdrg.SpecialCells(xlCellTypeVisible).Copy
            dCell.PasteSpecial xlPasteValues
            Set dCell = dCell.Offset(drCount)
        End If
    Next r

    Application.CutCopyMode = False
    sws.AutoFilterMode = False
    
    If dws Is ActiveSheet Then
        dws.Range("A1").Activate
    Else
        Dim ash As Worksheet: Set ash = ActiveSheet
        dws.Activate
        dws.Range("A1").Activate
        ash.Activate
    End If
    
    'wb.Save
    
    Application.ScreenUpdating = True
    
    MsgBox "Data transferred.", vbInformation, "Filter Names"
    
End Sub