基于Name列拆分多工作表Excel工作簿的VBA宏需求

问题背景 #

现有包含3个工作表的Excel工作簿，数据示例如下：

Sheet1数据 #

Sheet2数据 #

Sheet3数据 #

需求如下：

• 基于Name列（Sheet3对应表头为Client Name）拆分工作簿，生成多个独立工作簿，每个工作簿对应单个人员（如Alice、John）
• 每个新工作簿需包含原3个工作表，且仅展示该人员的数据
• 现有VBA代码仅能处理单个工作表的过滤，需要实现上述完整需求的宏代码

完整解决方案代码 #

Sub SplitWorkbookByPerson()
    Dim mainWB As Workbook
    Dim newWB As Workbook
    Dim ws As Worksheet
    Dim uniqueNames As Collection
    Dim name As Variant
    Dim lastRow As Long
    Dim filterCol As Integer
    Dim headerRow As Integer
    
    ' 设置表头行（假设所有工作表表头都在第1行）
    headerRow = 1
    
    ' 初始化主工作簿
    Set mainWB = ThisWorkbook
    ' 初始化唯一姓名集合
    Set uniqueNames = New Collection
    
    ' 从Sheet1获取所有唯一姓名（Sheet1的Name列在第1列）
    On Error Resume Next
    For Each cell In mainWB.Worksheets("Sheet1").Range("A2:A" & mainWB.Worksheets("Sheet1").Cells(mainWB.Worksheets("Sheet1").Rows.Count, 1).End(xlUp).Row)
        If cell.Value <> "" Then
            uniqueNames.Add cell.Value, Key:=CStr(cell.Value)
        End If
    Next cell
    On Error GoTo 0
    
    ' 遍历每个唯一姓名，创建对应工作簿
    For Each name In uniqueNames
        ' 创建新工作簿
        Set newWB = Workbooks.Add
        ' 遍历主工作簿的每个工作表
        For Each ws In mainWB.Worksheets
            ' 复制当前工作表到新工作簿
            ws.Copy After:=newWB.Worksheets(newWB.Worksheets.Count)
            ' 删除新工作簿默认的Sheet（如果存在）
            If newWB.Worksheets.Count > 1 Then
                Application.DisplayAlerts = False
                newWB.Worksheets("Sheet1").Delete
                Application.DisplayAlerts = True
            End If
            ' 重命名复制过来的工作表
            newWB.Worksheets(newWB.Worksheets.Count).Name = ws.Name
            
            ' 根据工作表确定过滤列
            Select Case ws.Name
                Case "Sheet1", "Sheet2"
                    filterCol = ws.Rows(headerRow).Find("Name").Column
                Case "Sheet3"
                    filterCol = ws.Rows(headerRow).Find("Client Name").Column
            End Select
            
            ' 应用筛选
            lastRow = newWB.Worksheets(ws.Name).Cells(newWB.Worksheets(ws.Name).Rows.Count, filterCol).End(xlUp).Row
            newWB.Worksheets(ws.Name).Range("A" & headerRow & ":" & newWB.Worksheets(ws.Name).Cells(headerRow, newWB.Worksheets(ws.Name).Columns.Count).Address).AutoFilter field:=filterCol, Criteria1:="<>" & name
            ' 删除不符合条件的行
            newWB.Worksheets(ws.Name).Range("A" & headerRow + 1 & ":A" & lastRow).SpecialCells(xlCellTypeVisible).EntireRow.Delete
            ' 关闭筛选
            newWB.Worksheets(ws.Name).AutoFilterMode = False
        Next ws
        
        ' 保存新工作簿（保存路径可自行修改，这里默认保存在主工作簿同目录）
        newWB.SaveAs Filename:=mainWB.Path & "\" & name & ".xlsx"
        newWB.Close SaveChanges:=False
    Next name
    
    MsgBox "拆分完成！"
End Sub

代码说明 #

1. 获取唯一人员列表：从Sheet1的Name列提取所有不重复的姓名，存入集合避免重复项
2. 创建新工作簿：遍历每个唯一姓名，生成对应的独立工作簿
3. 复制并处理工作表：
   • 将原工作簿的每个工作表复制到新工作簿，删除默认生成的空白工作表
   • 根据工作表名称自动匹配过滤列（Sheet3适配Client Name表头）
   • 启用自动筛选，删除当前人员以外的数据行，再关闭筛选保持格式整洁
4. 保存工作簿：以人员姓名命名新工作簿，默认保存在原工作簿同一目录下

注意事项 #

• 若工作表表头不在第1行，修改代码中的headerRow变量值
• 若工作表名称有变动，调整Select Case中的工作表名称匹配规则
• 运行前建议备份原工作簿，避免数据意外丢失

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