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

Question

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

我开始使用自动过滤器，然后使用计数数组，但出现错误并且没有过滤。因为过滤器应用于 sheet，但它似乎无法查找实际名称，而只是 returns 空白。它似乎确实在我的动态列表中计算了正确的名字数量......所以我接受了。

示例数据：工作sheet：姓名

工作sheet：书籍

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

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

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

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

在我的示例中，我创建了两个表 (Insert > Table)，将它们命名为 tblPeople 和 tblBooks。

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

关于您的代码：当您有大量数据时，此过程将非常缓慢。

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

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

Answer 2

过滤器名称

它将条件工作表（cws）的第B（cCol）列的值写入二维单-基于单列数组 (cData)。然后它将遍历数组中的值并通过数组的每个值过滤 源工作表 (sws) 的第 6 列 (scCol) 和将包含匹配单元格的源范围 (A:AA) 行复制到 目标工作表 (dws) 的第一个可用行，从第 [=19= 列开始] (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

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

Using Autofilter with a dynamic range

excel

vba

dynamic

autofilter

过滤器名称