如何修改Excel VBA拆分宏以包含第二个工作表的拆分数据

我有一个包含两个工作表的Excel文件，每个工作表都有表格，且两表均共有A列（Region）。每周一需按Region拆分这个含数千行数据的文件，最终得到约30个各含两个工作表的文件。现有一个仅能拆分第一个工作表的VBA宏，需要修改使其同时拆分第二个工作表并添加到对应Region的文件中。

修改思路 #

• 同时引用两个源工作表（Sheet1和Sheet2），确保后续能分别处理
• 从第一个工作表的Region列提取唯一值生成拆分字典（两表Region范围一致）
• 循环每个Region时，新建工作簿后先处理Sheet1的筛选复制，再添加新工作表处理Sheet2的内容
• 对每个源表重复「复制列宽→筛选Region→复制可见区域」的流程
• 清理源表的筛选状态，避免残留

修改后的完整代码 #

Sub Split_Files_With_TwoSheets()
    
    Const aibPrompt As String = "Which column would you like to filter by?"
    Const aibtitle As String = "Filter Column"
    Const aibDefault As Long = 1
    
    Dim dFileExtension As String: dFileExtension = ".xlsx"
    Dim dFileFormat As XlFileFormat: dFileFormat = xlOpenXMLWorkbook
    Dim dFolderPath As String: dFolderPath = "XYZ"
    
    ' 处理文件夹路径格式
    If Right(dFolderPath, 1) <> "\" Then dFolderPath = dFolderPath & "\"
    ' 检查文件夹是否存在
    If Len(Dir(dFolderPath, vbDirectory)) = 0 Then Exit Sub
    ' 处理文件扩展名格式
    If Left(dFileExtension, 1) <> "." Then dFileExtension = "." & dFileExtension
    
    Application.ScreenUpdating = False
    
    ' 获取筛选列
    Dim sCol As Variant
    sCol = Application.InputBox(aibPrompt, aibtitle, aibDefault, , , , , 1)
    If Len(CStr(sCol)) = 0 Or sCol = False Then Exit Sub
    
    ' 引用两个源工作表
    Dim sws1 As Worksheet: Set sws1 = ThisWorkbook.Worksheets("Sheet1")
    Dim sws2 As Worksheet: Set sws2 = ThisWorkbook.Worksheets("Sheet2")
    
    ' 清除源表的筛选状态（如果存在）
    If sws1.FilterMode Then sws1.ShowAllData
    If sws2.FilterMode Then sws2.ShowAllData
    
    ' 定义Sheet1的数据区域，用于提取唯一Region值
    Dim srg1 As Range: Set srg1 = sws1.Range("A1").CurrentRegion
    Dim srCount1 As Long: srCount1 = srg1.Rows.Count
    If srCount1 < 3 Then Exit Sub ' 数据行数不足，退出
    Dim srrg1 As Range: Set srrg1 = srg1.Rows(1) ' 表头行，用于复制列宽
    Dim scrg1 As Range: Set scrg1 = srg1.Columns(sCol)
    Dim scData1 As Variant: scData1 = scrg1.Value
    
    ' 生成唯一Region值的字典
    Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
    dict.CompareMode = vbTextCompare ' 不区分大小写
    
    Dim Key As Variant
    Dim r As Long
    
    For r = 2 To srCount1
        Key = scData1(r, 1)
        If Not IsError(Key) And Len(Key) > 0 Then ' 排除错误值和空值
            dict(Key) = Empty
        End If
    Next r
    If dict.Count = 0 Then Exit Sub ' 没有有效Region值，退出
    Erase scData1
    
    ' 定义Sheet2的数据区域
    Dim srg2 As Range: Set srg2 = sws2.Range("A1").CurrentRegion
    Dim srrg2 As Range: Set srrg2 = srg2.Rows(1) ' Sheet2的表头行
    
    Dim dwb As Workbook
    Dim dws As Worksheet
    Dim dfcell As Range
    Dim dFilePath As String
    
    ' 循环每个Region值，生成对应文件
    For Each Key In dict.Keys
        ' 新建工作簿（初始带1个工作表）
        Set dwb = Workbooks.Add(xlWBATWorksheet)
        
        ' ===== 处理Sheet1的内容 =====
        Set dws = dwb.Worksheets(1)
        dws.Name = sws1.Name ' 保留原工作表名称
        Set dfcell = dws.Range("A1")
        
        ' 复制列宽
        srrg1.Copy
        dfcell.PasteSpecial xlPasteColumnWidths
        
        ' 筛选并复制可见数据
        srg1.AutoFilter sCol, Key
        srg1.SpecialCells(xlCellTypeVisible).Copy dfcell
        sws1.ShowAllData ' 清除筛选
        
        ' ===== 处理Sheet2的内容 =====
        Set dws = dwb.Worksheets.Add(After:=dwb.Worksheets(dwb.Worksheets.Count))
        dws.Name = sws2.Name ' 保留原工作表名称
        Set dfcell = dws.Range("A1")
        
        ' 复制列宽
        srrg2.Copy
        dfcell.PasteSpecial xlPasteColumnWidths
        
        ' 筛选并复制可见数据
        srg2.AutoFilter sCol, Key
        srg2.SpecialCells(xlCellTypeVisible).Copy dfcell
        sws2.ShowAllData ' 清除筛选
        
        ' 保存并关闭工作簿
        dFilePath = dFolderPath & "Access Rights Review " & Key & dFileExtension
        Application.DisplayAlerts = False ' 覆盖文件不提示
        dwb.SaveAs dFilePath, dFileFormat
        Application.DisplayAlerts = True
        dwb.Close SaveChanges:=False
    Next Key
    
    ' 清除源表的筛选模式
    sws1.AutoFilterMode = False
    sws2.AutoFilterMode = False
    
    Application.ScreenUpdating = True
    MsgBox "所有文件已拆分完成。", vbInformation
    
End Sub

代码说明 #

• 新增Sheet2的处理逻辑，每个目标文件会包含两个工作表，名称与原表一致
• 保留原宏的筛选列输入功能，默认按A列（Region）拆分
• 优化路径和扩展名处理，确保格式正确
• 操作完成后自动清除源表筛选状态，避免残留
• 使用变量统一管理文件格式，代码更易维护

内容的提问来源于stack exchange，提问作者Gonçalo Malveiro