指定条件拆分Excel工作表（VBA版）

经常跟Excel打交道的人，相信或多或少会遇到这样一个问题：

一张大的汇总表，需要按某一列的值（如部门名称）拆分成多个Excel文件，然后分发给各个部门。

如果部门数较多的话，一个个去复制粘贴就太没效率了。

因为工作关系，每天都要跟一堆数据打交道，所以这里，我就分享一个通用一点的方法——使用Excel宏。

将一个Excel工作表拆分成多个Excel文件

Sub 拆分成多个工作簿()
 
    '输入用户想要拆分的工作表
    Dim sheet_name
    sheet_name = Application.InputBox("请输入拆分工作表的名称：")
    Worksheets(sheet_name).Select
 
    '输入获取拆分需要的条件列
    Dim col_name
    col_name = Application.InputBox("请输入拆分依据的列号(如A):")
 
    '输入拆分的开始行，要求输入的是数字
    Dim start_row As Integer
    start_row = Application.InputBox(prompt:="请输入拆分的开始行:", Type:=1)
 
    '暂停屏幕更新
    Application.ScreenUpdating = False
 
    '工作表的总行数
    Dim end_row
    end_row = Worksheets(sheet_name).UsedRange.Rows.Count
 
    '遍历计算所有拆分表，每个拆分表的格式为"表名称,表行数"
    '对于二维数组，ReDim只能扩充最后一维，因此sheet_map行不变，扩充列
    Dim sheet_map(), sheet_index
    ReDim sheet_map(1, 0)
    sheet_map(0, 0) = Range(col_name & start_row).Value
    sheet_map(1, 0) = 1
    sheet_index = 0
 
    With Worksheets(sheet_name)
        Dim row_count, temp, i
        row_count = 0
        For i = start_row + 1 To end_row
            temp = Range(col_name & i).Value
            If temp = Range(col_name & (i - 1)).Value Then
                sheet_map(1, sheet_index) = sheet_map(1, sheet_index) + 1
            Else
                ReDim Preserve sheet_map(1, sheet_index + 1)
                sheet_index = sheet_index + 1
                sheet_map(0, sheet_index) = temp
                sheet_map(1, sheet_index) = 1
            End If
        Next
    End With
 
    '根据前面计算的拆分表，拆分成单个文件
    Dim row_index
    row_index = start_row
    For i = 0 To sheet_index
        Workbooks.Add
        '创建最终数据文件夹
        Dim dir_name
        dir_name = ThisWorkbook.Path & "\拆分出的表格\"
        If Dir(dir_name, vbDirectory) = "" Then
            MkDir (dir_name)
        End If
        '创建新工作簿
        Dim workbook_path
        workbook_path = ThisWorkbook.Path & "\拆分出的表格\" & sheet_map(0, i) & ".xlsx"
        ActiveWorkbook.SaveAs workbook_path
        ActiveSheet.Name = sheet_map(0, i)
        '激活当前工作簿，ThisWorkbook表示当前跑代码的工作簿
        ThisWorkbook.Activate
 
        '拷贝条目数据(即最前面不需要拆分的数据行)
        Dim row_range
        row_range = 1 & ":" & (start_row - 1)
        Worksheets(sheet_name).Rows(row_range).Copy
        Workbooks(sheet_map(0, i) & ".xlsx").Sheets(1).Range("A1").PasteSpecial
        '拷贝拆分表的专属数据
        row_range = row_index & ":" & (row_index + sheet_map(1, i) - 1)
        Worksheets(sheet_name).Rows(row_range).Copy
        Workbooks(sheet_map(0, i) &a ".xlsx").Sheets(1).Range("A" & start_row).PasteSpecial
        row_index = row_index + sheet_map(1, i)
 
        '保存文件
        Workbooks(sheet_map(0, i) & ".xlsx").Close SaveChanges:=True
    Next
 
    '进行屏幕更新
    Application.ScreenUpdating = True
 
    MsgBox "拆分工作表完成"
End Sub

将一个Excel工作表拆分成多个工作表

Sub 拆分成多个工作表()
    Dim Arr, Rng As Range, Sht As Worksheet, Dic As Object
    Dim k, t, Str As String, i As Long, lc As Long
    '输入获取拆分需要的条件列
    Dim col_name
    col_name = Application.InputBox("请输入拆分依据的列号(如:第一列,输入:1):")
    Application.ScreenUpdating = False '关闭屏幕更新
    Arr = Range("A1").CurrentRegion.Value
    lc = UBound(Arr, 2) '求取最后一列的列号
    Set Rng = Rows(1) '标题行
    Set Dic = CreateObject("Scripting.Dictionary") '创建字典
    For i = 2 To UBound(Arr)
        Str = Arr(i, col_name) '条件列，关键字
        If Not Dic.Exists(Str) Then '如果字典没有关键字
            Set Dic(Str) = Cells(i, 1).Resize(, lc) '把当前行装入到字典中
        Else '否则(字典中存在关键字)
            Set Dic(Str) = Union(Dic(Str), Cells(i, 1).Resize(, lc)) '把行连合起来
        End If
    Next
    k = Dic.Keys '字典关键字集合
    t = Dic.Items '字典项目集合
    On Error Resume Next
    With Sheets
        For i = 0 To Dic.Count - 1 '循环关键字的个数
            Set Sht = .Item(k(i)) '给变量赋值(工作表名为关键字)
            If Sht Is Nothing Then '该工作表不存在则插入一个空工作表
                .Add(After:=.Item(.Count)).Name = k(i) '新建的工作表将置于所有工作表之后，并命名为关键字
                Set Sht = ActiveSheet '活动工作表给变量
            Else '否则
                Sht.Cells.Clear '清除工作中所有内容和格式
            End If
            Rng.Copy Sht.Range("A1") '把标题写入第一行
            t(i).Copy Sht.Range("A2") '写入其他内容
            Sht.Cells.EntireColumn.AutoFit '自动调整全工作表单元格的列宽
            Set Sht = Nothing '变量处于初始状态
        Next
    End With
    Sheets(1).Activate '第1个工作表处于激活状态
    Application.ScreenUpdating = True '打开屏幕更新
    MsgBox "拆分工作表完成"
End Sub

因为近期自己也在自学Python，后面会分享另一种方法，使用Python来完成这个项任务。