如何修改VBA代码实现多工作表按公司名拆分并生成对应工作簿

修改后的代码 #

Sub SplitMultiSheetsByColToWorkbooks()
    ' 功能：将包含多工作表的工作簿按指定列（如公司名）拆分，为每个唯一值生成包含对应多工作表数据的独立工作簿
    Dim originalWB As Workbook
    Dim newWB As Workbook
    Dim ws As Worksheet
    Dim newWS As Worksheet
    Dim lr As Long
    Dim vcol As Integer
    Dim i As Integer, j As Integer
    Dim uniqueValues As Variant
    Dim titleRange As String
    Dim titleRow As Integer
    Dim headerRange As Range
    Dim splitColRange As Range
    Dim savePath As String
    
    ' 设置保存路径，请根据实际修改
    savePath = "C:\Users\AddinsVM001\Desktop\拆分结果\"
    ' 确保保存路径末尾有斜杠
    If Right(savePath, 1) <> "\" Then savePath = savePath & "\"
    
    ' 关闭弹窗提示、禁用屏幕刷新，加快运行速度
    Application.DisplayAlerts = False
    Application.ScreenUpdating = False
    
    Set originalWB = ThisWorkbook
    
    ' 选择表头区域（仅需在第一个工作表选择一次）
    Set headerRange = Application.InputBox("请选择表头行区域：", "表头选择", Type:=8)
    If TypeName(headerRange) = "Nothing" Then GoTo Cleanup
    titleRange = headerRange.Address(False, False)
    titleRow = headerRange.Row
    
    ' 选择拆分依据的列（仅需在第一个工作表选择一次）
    Set splitColRange = Application.InputBox("请选择拆分依据的列：", "拆分列选择", Type:=8)
    If TypeName(splitColRange) = "Nothing" Then GoTo Cleanup
    vcol = splitColRange.Column
    
    ' 从第一个工作表提取所有唯一值
    With originalWB.Sheets(1)
        .Columns(vcol).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=.Cells(1, .Columns.Count), Unique:=True
        uniqueValues = Application.Transpose(.Cells(1, .Columns.Count).Resize(.Cells(.Rows.Count, .Columns.Count).End(xlUp).Row).Value)
        .Cells(1, .Columns.Count).Resize(.Cells(.Rows.Count, .Columns.Count).End(xlUp).Row).ClearContents
    End With
    
    ' 遍历每个唯一值
    For i = 2 To UBound(uniqueValues)
        ' 创建新工作簿
        Set newWB = Workbooks.Add
        ' 遍历原工作簿的每个工作表
        For Each ws In originalWB.Sheets
            ' 在新工作簿添加新工作表并命名为原表名称
            Set newWS = newWB.Sheets.Add(After:=newWB.Sheets(newWB.Sheets.Count))
            newWS.Name = ws.Name
            
            ' 过滤当前工作表的数据
            ws.Range(titleRange).AutoFilter Field:=vcol, Criteria1:=uniqueValues(i)
            ' 复制可见行到新工作表
            ws.Range("A" & titleRow & ":A" & ws.Cells(ws.Rows.Count, vcol).End(xlUp).Row).SpecialCells(xlCellTypeVisible).EntireRow.Copy
            newWS.Cells(1, 1).PasteSpecial Paste:=xlPasteAll
            ' 清除当前表的筛选状态
            ws.AutoFilterMode = False
        Next ws
        
        ' 删除新工作簿默认的空白工作表（如果存在）
        On Error Resume Next
        newWB.Sheets("Sheet1").Delete
        On Error GoTo 0
        
        ' 保存新工作簿
        newWB.SaveAs Filename:=savePath & uniqueValues(i) & ".xlsx"
        newWB.Close SaveChanges:=False
    Next i
    
Cleanup:
    ' 恢复Excel默认设置
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
    originalWB.Activate
    MsgBox "拆分完成！结果已保存至：" & savePath, vbInformation
End Sub

使用步骤（针对无VBA基础用户） #

• 打开需要拆分的Excel工作簿。
• 按下快捷键 Alt + F11 打开VBA编辑器。
• 在编辑器左侧「工程资源管理器」中，右键点击当前工作簿名称，选择「插入」→「模块」。
• 将上述代码复制粘贴到新模块的代码窗口中。
• 修改代码中的 savePath 变量值，设置为你想要保存拆分结果的文件夹路径（示例：savePath = "D:\拆分结果\"）。
• 按下 F5 键运行代码，或点击编辑器工具栏的绿色三角「运行」按钮。
• 按照弹窗提示，先选择表头行区域（如第一行或前两行表头），再选择拆分依据的列（如公司名所在的整列或任意一个单元格）。
• 等待程序运行完成，拆分后的工作簿会自动保存到设置的路径下。

注意事项 #

• 确保所有工作表的表头结构一致，且拆分依据的列在每个工作表中位置相同。
• 保存路径对应的文件夹必须已存在，若不存在请手动创建。
• 运行前建议备份原工作簿，避免意外数据丢失。

内容的提问来源于stack exchange，提问作者mahmoud zain Zain