如何用VBA基于双筛选条件将数据拆分至多个新工作簿？

以下是修改后的VBA代码，可实现按选中Desk下的每位人员生成独立工作簿，满足数据隔离、空报表生成等需求：

代码说明 #

• 新增映射表读取逻辑，自动获取选中Desk对应的所有人员
• 对每位人员执行Desk+Person双重筛选
• 无对应数据时自动生成仅含表头的空报表
• 工作簿命名严格遵循Desk_1_Anastasia格式

修改后的完整代码 #

Option Explicit

Sub GeneratePersonWorkbooks()
    Dim RelationSheet As Worksheet
    Dim InstructionSheet As Worksheet
    Dim DeskPersonMap As Worksheet ' 存储Desk-人员映射的工作表
    Dim wb As Workbook, sht As Worksheet
    Dim selectedDesk As String
    Dim START_CELL As String
    Dim lastRowMap As Long, i As Long
    Dim personName As String
    Dim headerRange As Range, dataRange As Range
    
    ' 绑定工作表（请根据你的实际表结构调整）
    Set InstructionSheet = Sheet2 ' 选择Desk的操作表
    Set RelationSheet = Sheet1 ' 存储主数据的工作表
    Set DeskPersonMap = Sheet4 ' 存储Desk-Person映射关系的工作表
    selectedDesk = InstructionSheet.Cells(14, 3).Text
    START_CELL = "B5" ' 主数据的起始单元格
    
    ' 获取映射表的最后一行（假设表头在第1行）
    lastRowMap = DeskPersonMap.Cells(DeskPersonMap.Rows.Count, "A").End(xlUp).Row
    
    ' 遍历映射表，为每位符合条件的人员生成工作簿
    For i = 2 To lastRowMap
        If DeskPersonMap.Cells(i, "A").Value = selectedDesk Then
            personName = DeskPersonMap.Cells(i, "B").Value
            
            ' 创建新工作簿并设置工作表名称
            Set wb = Workbooks.Add
            Set sht = wb.ActiveSheet
            sht.Name = "RELATION LEVEL"
            
            ' 先复制表头格式与内容
            Set headerRange = RelationSheet.Range(START_CELL).CurrentRegion.Rows(1)
            headerRange.Copy
            sht.Cells(1, 1).PasteSpecial Paste:=xlPasteFormats
            sht.Cells(1, 1).PasteSpecial Paste:=xlPasteValues
            
            ' 执行双重筛选：Desk列+Person列（替换Field:=X为Person列的实际序号）
            With RelationSheet.Range(START_CELL)
                .AutoFilter Field:=4, Criteria1:=selectedDesk ' 原Desk筛选列（Field4）
                .AutoFilter Field:=5, Criteria1:=personName ' 替换为Person列的序号，比如Field5
            End With
            
            ' 尝试复制筛选后的可见数据（跳过已复制的表头）
            On Error Resume Next
            Set dataRange = RelationSheet.Range(START_CELL).CurrentRegion.Offset(1).SpecialCells(xlCellTypeVisible)
            On Error GoTo 0
            
            If Not dataRange Is Nothing Then
                dataRange.Copy
                sht.Cells(2, 1).PasteSpecial Paste:=xlPasteFormats
                sht.Cells(2, 1).PasteSpecial Paste:=xlPasteValues
            End If
            
            ' 设置冻结窗格（保留原代码逻辑）
            With wb.ActiveWindow
                If .FreezePanes Then .FreezePanes = False
                .SplitColumn = 1
                .SplitRow = 2
                .FreezePanes = True
            End With
            
            ' 保存并关闭工作簿（替换为你的目标路径）
            wb.SaveAs Filename:="C:\Your_Target_Folder\" & Replace(selectedDesk, " ", "_") & "_" & personName & ".xlsx"
            wb.Close SaveChanges:=False
            
            ' 清除筛选，恢复主数据状态
            RelationSheet.ShowAllData
            RelationSheet.AutoFilterMode = False
            Application.CutCopyMode = False
        End If
    Next i
    
    MsgBox "所有工作簿已生成完成！", vbInformation
End Sub

关键修改点 #

1. 映射表集成：新增DeskPersonMap对象，自动读取选中Desk对应的人员列表
2. 双重筛选逻辑：在原Desk筛选基础上，新增Person列筛选（需替换代码中Field:=5为实际Person列的序号）
3. 空报表处理：先复制表头，无数据时仅保留表头内容
4. 命名规范实现：用Replace函数将"Desk 1"转为"Desk_1"，拼接人员姓名生成合规文件名
5. 批量生成：通过循环为每位人员创建独立工作簿，确保数据完全隔离

使用注意事项 #

• 确认DeskPersonMap指向你的映射表（若映射表不是Sheet4，可改为Set DeskPersonMap = ThisWorkbook.Worksheets("映射表名称")）
• 务必替换Field:=5为Person列在主数据中的实际序号
• 修改SaveAs中的保存路径为你的目标文件夹
• 若映射表存在重复的Desk-Person组合，建议先对映射表去重，避免重复生成工作簿

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