Excel VBA中对动态范围使用Autofilter按指定名单筛选数据

原代码核心问题 #

• 438错误触发原因：With ThisWorkbook.Sheets("Books") 块内的属性已默认绑定Books工作表，代码多余书写.ThisWorkbook导致对象识别失败，触发「对象不支持该属性或方法」报错。
• 筛选无结果原因：① 姓名数组取值列不匹配：统计Names表最后一行用的是B列（Person列），实际取姓名却读取了A列内容，拿到空值自然无法匹配；② 逐次循环筛选单个姓名，每次筛选会覆盖上一次的结果，逻辑错误。
• 复制粘贴逻辑缺陷：直接调用.Paste方法稳定性差，且重复粘贴会覆盖已有内容，没有适配数据追加逻辑。

修正后可运行代码 #

Sub FilterName()
    Dim lastrow_Name As Long, lastrow_Books As Long
    Dim arrSummary As Variant
    Dim targetRng As Range
    
    ' 关闭屏幕更新提升运行效率
    Application.ScreenUpdating = False
    
    ' 读取Names表B列（Person列）动态姓名名单
    With ThisWorkbook.Sheets("Names")
        lastrow_Name = .Cells(.Rows.Count, "B").End(xlUp).Row
        ' 批量读取数据到数组，无需循环
        arrSummary = .Range("B1:B" & lastrow_Name).Value
        ' 转为一维数组适配Autofilter多值筛选要求
        arrSummary = Application.Transpose(arrSummary)
    End With
    
    ' 执行Books表筛选操作
    With ThisWorkbook.Sheets("Books")
        ' 先清除原有筛选，避免异常
        If .AutoFilterMode Then .AutoFilterMode = False
        ' 自动识别Books表有效数据范围，无需写死行数
        lastrow_Books = .Cells(.Rows.Count, "F").End(xlUp).Row
        ' 批量筛选F列匹配所有名单内的姓名
        .Range("F1:F" & lastrow_Books).AutoFilter Field:=1, Criteria1:=arrSummary, Operator:=xlFilterValues
        
        ' 捕获无匹配数据的异常场景
        On Error Resume Next
        Set targetRng = .Range("A1:AA" & lastrow_Books).SpecialCells(xlCellTypeVisible)
        On Error GoTo 0
        
        If Not targetRng Is Nothing Then
            ' 清空Loans表原有内容后写入新结果，如需追加可修改此处定位到空白行
            ThisWorkbook.Sheets("Loans").Cells.Clear
            targetRng.Copy Destination:=ThisWorkbook.Sheets("Loans").Range("A1")
        Else
            MsgBox "未查询到匹配姓名的相关记录"
        End If
        ' 恢复Books表原始显示状态
        .AutoFilterMode = False
    End With
    
    Application.ScreenUpdating = True
    MsgBox "筛选操作执行完成，结果已同步至Loans表"
End Sub

功能说明 #

• 自动适配Names表Person列的姓名增删，无需修改代码
• 一次性完成多值筛选，无需循环操作，运行效率更高
• 增加异常处理逻辑，无匹配数据时不会触发报错
• 自动识别有效数据范围，无需硬编码行数适配不同月度数据量

内容的提问来源于stack exchange，提问作者PeepDeep