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

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

过滤器名称

它将写入列 B 中的值( cCol ) 的 标准工作表 ( cws ) 到 2D 基于一的一列数组 ( cData )。然后它将遍历数组中的值并过滤 的第 6 列 (scCol)源工作表 ( sws ) 通过每个数组的值并将包含匹配单元格的源范围的 ( A:AA ) 行复制到 的第一个可用行目的地工作表 ( 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