合并Excel VBA宏实现按列拆分数据至独立工作簿及工作表

需要实现的功能：将当前工作表中的大型数据，先按A列的唯一值拆分生成多个独立工作簿（每个工作簿对应A列的一个唯一值），再在每个生成的工作簿中，按B列的唯一值拆分为多个独立工作表（每个工作表对应B列的一个唯一值）。

合并后的完整VBA代码 #

Option Explicit

Sub SplitDataToWorkbooksAndSheets()
    ' 配置参数
    Const SAVE_FOLDER As String = "C:\Test\" ' 工作簿保存路径，需提前创建
    Const FILE_EXTENSION As String = ".xlsx"
    Const FILE_FORMAT As XlFileFormat = xlOpenXMLWorkbook
    Const SPLIT_COL_WORKBOOK As Long = 1 ' 按A列拆分工作簿（A=1, B=2...）
    Const SPLIT_COL_WORKSHEET As Long = 2 ' 按B列拆分工作表
    
    Dim srcWs As Worksheet
    Dim srcRng As Range
    Dim lastRow As Long
    Dim dictWorkbooks As Object
    Dim wbKey As Variant
    Dim tempWb As Workbook
    Dim tempWs As Worksheet
    Dim dictSheets As Object
    Dim wsKey As Variant
    Dim headerRow As Range
    
    ' 初始化设置，提升运行效率
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    
    Set srcWs = ActiveSheet
    If srcWs.AutoFilterMode Then srcWs.AutoFilterMode = False
    
    ' 获取源数据区域（含表头）
    Set srcRng = srcWs.Range("A1").CurrentRegion
    lastRow = srcRng.Rows.Count
    If lastRow < 2 Then
        MsgBox "数据行数不足，无法拆分！", vbExclamation
        GoTo Cleanup
    End If
    Set headerRow = srcRng.Rows(1)
    
    ' 检查保存文件夹是否存在
    Dim savePath As String
    savePath = SAVE_FOLDER
    If Right(savePath, 1) <> "\" Then savePath = savePath & "\"
    If Len(Dir(savePath, vbDirectory)) = 0 Then
        MsgBox "指定的保存文件夹不存在！", vbCritical
        GoTo Cleanup
    End If
    
    ' 获取A列的唯一值，用于生成工作簿
    Set dictWorkbooks = CreateObject("Scripting.Dictionary")
    dictWorkbooks.CompareMode = vbTextCompare
    
    For lastRow = 2 To srcRng.Rows.Count
        wbKey = srcRng.Cells(lastRow, SPLIT_COL_WORKBOOK).Value
        If Not IsError(wbKey) And Len(wbKey) > 0 Then
            dictWorkbooks(wbKey) = Empty
        End If
    Next lastRow
    
    If dictWorkbooks.Count = 0 Then
        MsgBox "A列无有效唯一值，无法生成工作簿！", vbExclamation
        GoTo Cleanup
    End If
    
    ' 遍历每个A列唯一值，生成工作簿并按B列拆分工作表
    For Each wbKey In dictWorkbooks.Keys
        ' 创建新工作簿
        Set tempWb = Workbooks.Add(xlWBATWorksheet)
        Set tempWs = tempWb.Worksheets(1)
        
        ' 复制当前A列值对应的筛选数据到临时工作表
        srcRng.AutoFilter Field:=SPLIT_COL_WORKBOOK, Criteria1:=wbKey
        srcRng.SpecialCells(xlCellTypeVisible).Copy tempWs.Range("A1")
        srcWs.ShowAllData
        
        ' 复制表头列宽，保留格式
        headerRow.Copy
        tempWs.Range("A1").PasteSpecial xlPasteColumnWidths
        
        ' 获取临时工作表中的数据区域，准备按B列拆分
        Dim tempRng As Range
        Set tempRng = tempWs.Range("A1").CurrentRegion
        If tempRng.Rows.Count < 2 Then
            tempWb.Close SaveChanges:=False
            GoTo NextWorkbook
        End If
        
        ' 获取B列的唯一值，用于生成工作表
        Set dictSheets = CreateObject("Scripting.Dictionary")
        dictSheets.CompareMode = vbTextCompare
        
        For lastRow = 2 To tempRng.Rows.Count
            wsKey = tempRng.Cells(lastRow, SPLIT_COL_WORKSHEET).Value
            If Not IsError(wsKey) And Len(wsKey) > 0 Then
                dictSheets(wsKey) = Empty
            End If
        Next lastRow
        
        ' 遍历每个B列唯一值，生成工作表
        For Each wsKey In dictSheets.Keys
            ' 创建新工作表
            tempWb.Sheets.Add After:=tempWb.Sheets(tempWb.Sheets.Count)
            tempWb.Sheets(tempWb.Sheets.Count).Name = wsKey
            
            ' 筛选B列数据并复制到新工作表
            tempRng.AutoFilter Field:=SPLIT_COL_WORKSHEET, Criteria1:=wsKey
            tempRng.SpecialCells(xlCellTypeVisible).Copy tempWb.Sheets(wsKey).Range("A1")
            tempWs.ShowAllData
            
            ' 复制列宽
            headerRow.Copy
            tempWb.Sheets(wsKey).Range("A1").PasteSpecial xlPasteColumnWidths
        Next wsKey
        
        ' 删除初始的空工作表（如果已生成拆分工作表）
        If tempWb.Sheets.Count > 1 Then
            tempWs.Delete
        End If
        
        ' 保存并关闭工作簿
        tempWb.SaveAs savePath & wbKey & FILE_EXTENSION, FILE_FORMAT
        tempWb.Close SaveChanges:=False
        
NextWorkbook:
        Set tempWb = Nothing
        Set tempWs = Nothing
    Next wbKey
    
    ' 清理操作，恢复Excel默认设置
Cleanup:
    srcWs.AutoFilterMode = False
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    MsgBox "数据拆分完成！", vbInformation
End Sub

使用说明 #

• 配置参数：修改代码开头的SAVE_FOLDER为你的目标保存路径，确保该文件夹已提前创建。
• 列调整：若需要更改拆分列，修改SPLIT_COL_WORKBOOK和SPLIT_COL_WORKSHEET的数字（A列对应1，B列对应2，以此类推）。
• 运行方式：打开目标Excel文件，按Alt+F11打开VBA编辑器，插入模块并粘贴上述代码，返回Excel界面运行该宏即可。

核心优化 #

• 用Scripting.Dictionary高效提取唯一值，避免重复拆分
• 关闭屏幕刷新和系统提示，大幅提升处理速度
• 保留表头列宽，保证拆分后的数据格式一致性
• 自动跳过空值和错误值，避免无效操作

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