求助：基于经理列表批量筛选数据至对应工作表的VBA循环实现

以下是修正并完善后的VBA代码，可实现你需要的功能：

Sub FilterAndCopyManagerData()
    ' 定义工作簿对象
    Dim wbManagers As Workbook
    Dim wbReports As Workbook
    
    ' 定义工作表对象
    Dim wsManagerList As Worksheet
    Dim wsAllReports As Worksheet
    Dim wsTarget As Worksheet
    
    ' 定义循环变量和范围变量
    Dim managerCell As Range
    Dim lastRowManager As Long
    Dim lastRowReports As Long
    Dim filterColumn As Integer
    
    ' --------------------------
    ' 1. 引用工作簿和工作表（根据实际名称调整）
    ' --------------------------
    ' 若工作簿未打开，替换为Workbooks.Open("完整文件路径")，例如：
    ' Set wbManagers = Workbooks.Open("C:\Documents\Managers.xlsx")
    Set wbManagers = Workbooks("Managers.xlsx")
    Set wbReports = Workbooks("Reports.xlsx")
    
    Set wsManagerList = wbManagers.Worksheets("Sheet1") ' 替换为Managers中存经理列表的工作表名
    Set wsAllReports = wbReports.Worksheets("Sheet1") ' 替换为Reports中存全部数据的工作表名
    
    ' 设置Reports数据中"经理"列的列号（比如经理在B列，就设为2）
    filterColumn = 2
    
    ' --------------------------
    ' 2. 获取经理列表的最后一行（自动适配列表长度）
    ' --------------------------
    lastRowManager = wsManagerList.Cells(wsManagerList.Rows.Count, "A").End(xlUp).Row
    
    ' --------------------------
    ' 3. 遍历每个经理
    ' --------------------------
    For Each managerCell In wsManagerList.Range("A2:A" & lastRowManager) ' 假设A1是表头，从A2开始是经理姓名
        Dim managerName As String
        managerName = managerCell.Value
        
        ' 跳过空单元格
        If managerName = "" Then GoTo NextManager
        
        ' 检查目标工作表是否存在（题目说明已存在，保留作为容错）
        On Error Resume Next
        Set wsTarget = wbReports.Worksheets(managerName)
        On Error GoTo 0
        
        If wsTarget Is Nothing Then
            MsgBox "未找到名为" & managerName & "的工作表，跳过该经理"
            GoTo NextManager
        End If
        
        ' --------------------------
        ' 4. 清除目标工作表原有数据（若要保留表头，改为wsTarget.Rows("2:" & wsTarget.Rows.Count).ClearContents）
        ' --------------------------
        wsTarget.Cells.ClearContents
        
        ' --------------------------
        ' 5. 在总数据工作表中筛选当前经理的下属
        ' --------------------------
        wsAllReports.AutoFilterMode = False ' 清除之前的筛选状态
        wsAllReports.Range("A1").CurrentRegion.AutoFilter Field:=filterColumn, Criteria1:=managerName
        
        ' --------------------------
        ' 6. 复制筛选后的可见数据到目标工作表
        ' --------------------------
        lastRowReports = wsAllReports.Cells(wsAllReports.Rows.Count, "A").End(xlUp).Row
        If lastRowReports > 1 Then ' 确保筛选后有数据（表头不算）
            wsAllReports.Range("A1:Z" & lastRowReports).SpecialCells(xlCellTypeVisible).Copy _
                Destination:=wsTarget.Range("A1")
        End If
        
        ' 清除筛选
        wsAllReports.AutoFilterMode = False
        
NextManager:
        Set wsTarget = Nothing ' 重置对象变量，避免后续循环出错
    Next managerCell
    
    MsgBox "所有经理数据已处理完成！"
End Sub

关键修正与说明 #

• 对象变量赋值：VBA中对象类型变量必须用Set关键字赋值，原代码未正确引用工作簿/工作表，现已修正为标准写法
• 动态循环范围：替换原固定的1 To 127循环，改为遍历经理列表的实际单元格，自动适配列表长度，避免遗漏或超出范围
• 筛选逻辑实现：使用AutoFilter方法指定筛选列和经理姓名，通过SpecialCells(xlCellTypeVisible)获取筛选后的可见数据
• 容错处理：增加目标工作表存在性检查，避免因工作表名称不匹配导致报错
• 数据清理：复制前清空目标工作表原有数据，防止新旧数据重叠

使用注意事项 #

• 替换代码中的工作表名称（如Sheet1改为实际表名）
• 调整filterColumn的值为Reports中"经理"列的列号（例如经理在C列则设为3）
• 若工作簿未提前打开，将工作簿引用代码替换为Workbooks.Open("完整文件路径")
• 若经理列表无表头，将循环范围改为wsManagerList.Range("A1:A" & lastRowManager)

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