Excel VBA按列拆分工作表和工作簿的实现

Sub 工作表按列拆分为工作表()
    '当前工作表（worksheet）按固定某列的值拆分为多个工作表，保存在当前工作簿（workbook）
    Dim arr, dict As Object
    Set dict = CreateObject("scripting.dictionary")
'--------------------参数填写：num_col，数字，A列为1向右递增；title_row，数字，第1行为1向下递增
    num_col = 4  '关键值列，按该列的值进行拆分，相同的保存在同一ws
    title_row = 1  '表头行，每个拆分后的sheet都保留
    Set ws = Application.ActiveSheet
    arr = ActiveSheet.UsedRange  '所有数据行读取为数组，也可arr = [a1].CurrentRegion
    
    For i = title_row + 1 To UBound(arr):  '遍历关键值列，写入字典，key为关键值，item为对应的行
        If Not dict.Exists(arr(i, num_col)) Then  '新键-值
            Set dict(arr(i, num_col)) = Rows(i)
        Else  '已有键-值，更新
            Set dict(arr(i, num_col)) = Union(dict(arr(i, num_col)), Rows(i))
        End If
    Next
    
    k = dict.Keys:v = dict.Items
    For i = 0 To dict.count - 1:  '遍历字典，创建、写入ws
        'Worksheets.Add(after:=Sheets(Sheets.count)).Name = "拆分表" & i + 1  '最后添加新sheet，序号命名
        Worksheets.Add(after:=Sheets(Sheets.count)).Name = "拆分表_" & k(i)  '最后添加新sheet，keys命名
        With ActiveSheet
            ws.Rows(1).Copy
            .[a1].PasteSpecial Paste:=xlPasteColumnWidths  '复制列宽
            ws.Rows(1 & ":" & title_row).Copy .[a1]  '复制表头
            v(i).Copy .Range("A" & title_row + 1)  '复制数据
        End With
        'Exit For  '强制退出for循环，单次测试使用
    Next
End Sub

Sub 工作表按列拆分为工作簿()
    '当前工作表（worksheet）按固定某列的值拆分为多个工作簿（workbook），文件单独保存
    Dim arr, dict As Object
    Set dict = CreateObject("scripting.dictionary"): tm = Timer
    Set fso = CreateObject("Scripting.FileSystemObject")
'--------------------参数填写：num_col，数字，A列为1向右递增；title_row，数字，第1行为1向下递增
    num_col = 4  '关键值列，按该列的值进行拆分，相同的保存在同一ws
    title_row = 1  '表头行，每个拆分后的sheet都保留
    Set ws = Application.ActiveSheet
    wb_path = Application.ActiveWorkbook.Path  '当前工作簿文件路径
    wb_name = Application.ActiveWorkbook.Name  '当前工作簿文件名和扩展名
    save_path = wb_path + "\拆分表"  '保存拆分后的表格保存路径
    If Not fso.FolderExists(save_path) Then fso.CreateFolder (save_path)  '创建文件夹
    Application.ScreenUpdating = False  '关闭屏幕更新，加快程序运行
    Application.DisplayAlerts = False   '不显示警告信息
    
    arr = ActiveSheet.UsedRange  '所有数据行读取为数组，也可arr = [a1].CurrentRegion
    For i = title_row + 1 To UBound(arr):  '遍历关键值列，写入字典，key为关键值，item为对应的行
        If Not dict.Exists(arr(i, num_col)) Then  '新键-值
            Set dict(arr(i, num_col)) = Rows(i)
        Else  '已有键-值，更新
            Set dict(arr(i, num_col)) = Union(dict(arr(i, num_col)), Rows(i))
        End If
    Next
    
    k = dict.Keys:v = dict.Items
    For i = 0 To dict.count - 1:  '遍历字典，创建、写入wb
        Workbooks.Add
        With ActiveSheet
            ws.Rows(1).Copy
            .[a1].PasteSpecial Paste:=xlPasteColumnWidths  '复制列宽
            ws.Rows(1 & ":" & title_row).Copy .[a1]  '复制表头
            v(i).Copy .Range("A" & title_row + 1)  '复制数据
        End With
        '保存文件全名（文件路径、文件名、扩展名），keys命名
        save_file = save_path & "\" & fso.GetBaseName(wb_name) & "_拆分表_" & k(i) & "." & fso.GetExtensionName(wb_name)
        ActiveWorkbook.SaveAs filename:=save_file
        ActiveWorkbook.Close (False)
        'Exit For  '强制退出for循环，单次测试使用
    Next
    
    Set fso = Nothing  '释放内存
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    Debug.Print "工作表已拆分完成，累计用时" & Format(Timer - tm, "0.00")  '耗时
End Sub

Private Function RE_STR(source_str As String, pat As String, Optional replace_str As String = "$1")
    '通用正则替换函数，函数定义RE(字符串，正则模式，替换值)对单元格返回正则替换后的字符串
    With CreateObject("vbscript.regexp")  '正则表达式
        .Global = True
        .Pattern = pat
        RE_STR = .Replace(source_str, replace_str)
    End With
End Function

Sub 工作簿按列拆分()
    '当前工作簿wb所有工作表ws按一列的值拆分为多个工作簿，新旧工作簿形式一致，以列值命名新wb
    Dim arr, dict As Object, fso As Object, title_row&, num_col&, i&
'--------------------参数填写：num_col，数字，A列为1向右递增；title_row，数字，第1行为1向下递增
    title_row = 1  '表头行，每个拆分后的sheet都保留
    num_col = 0    '关键值列，按该列的值进行拆分，相同的保存在同一ws，为0时使用key_col
    key_col = "属地"  '首行关键值，当各工作表关键值列号不同时，使用关键值动态确定num_col（初始为0）
    Set dict = CreateObject("scripting.dictionary"): tm = Timer
    Set fso = CreateObject("Scripting.FileSystemObject")
    Application.ScreenUpdating = False  '关闭屏幕更新，加快程序运行
    Application.DisplayAlerts = False   '不显示警告信息
    
    With ActiveWorkbook  '拆分当前工作簿
        save_path = .path + "\拆分表"  '保存拆分后的表格保存路径
        wb_name = .Name  '当前工作簿文件名和扩展名
        If Not fso.FolderExists(save_path) Then fso.CreateFolder (save_path)  '创建文件夹
        For Each sht In .Worksheets
            If num_col > 0 Then
                col = num_col
            ElseIf num_col = 0 Then  '为0时使用key_col动态确定num_col
                For i = 1 To sht.UsedRange.Columns.Count
                    If sht.Cells(1, i).Value = key_col Then col = i
                Next
            End If
            arr = sht.UsedRange
            For i = title_row + 1 To UBound(arr)  '遍历关键值列，写入字典，key为关键值，item为对应的行
                If Len(arr(i, col)) > 0 Then      '关键值列不为空
                    If Not dict.Exists(arr(i, col)) Then  '新键-值
                        Set dict(arr(i, col)) = sht.Rows(i)
                    Else  '已有键-值，更新
                        Set dict(arr(i, col)) = Union(dict(arr(i, col)), sht.Rows(i))  'Union,range对象
                    End If
                End If
            Next
            k = dict.keys: v = dict.Items
            For i = 0 To dict.Count - 1:  '遍历字典，创建、写入wb
                Workbooks.Add
                With ActiveSheet
                    .Name = sht.Name  '工作表命名
                    sht.Rows(1).Copy
                    .[a1].PasteSpecial Paste:=xlPasteColumnWidths  '复制列宽
                    sht.Rows(1 & ":" & title_row).Copy .[a1]       '复制表头
                    v(i).Copy .Range("A" & title_row + 1)          '复制数据
                End With
                Set ws = Application.ActiveSheet
                '保存文件全名（文件路径、文件名、扩展名），keys命名
                file_name = RE_STR(CStr(k(i)), "[\\/:*?""<>|]", "")  '删除文件名非法字符
                save_file = save_path & "\" & file_name & "." & fso.GetExtensionName(wb_name)
                If Not fso.FileExists(save_file) Then  '文件不存在，创建
                    ActiveWorkbook.SaveAs filename:=save_file
                    ActiveWorkbook.Close (False)
                Else  '文件存在，复制
                    Set save_wb = Application.Workbooks.Open(save_file)  '打开文件
                    ws.Copy After:=Sheets(save_wb.Sheets.Count)
                    save_wb.Close (True)
                    ActiveWorkbook.Close (False)
                End If
            Next
            dict.RemoveAll  '清空字典
        Next
    End With
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    Debug.Print "工作簿已拆分完成，累计用时" & Format(Timer - tm, "0.00")  '耗时
End Sub

Sub 工作簿按列拆分_删除法()
    '当前工作簿wb所有工作表ws按一列的值拆分为多个工作簿，新旧工作簿形式一致，以列值命名新wb
    '采用删除非同一关键值的方法；同时使用字典定义参数，可实现每个ws表头行数与关键值列号都不同
    Dim arr, args_dict As Object, dict As Object, fso As Object, rng As Range, t&, c&, i&
    Set args_dict = CreateObject("scripting.dictionary")  '参数字典
'--------------------参数填写：字典(工作表名)= Array(表头行数, 关键值列号)；如果工作表名未在字典中，则不拆分
    args_dict("A级") = Array(1, 4): args_dict("B级") = Array(1, 3): args_dict("C级") = Array(1, 3)
    Set dict = CreateObject("scripting.dictionary"): tm = Timer
    Set fso = CreateObject("Scripting.FileSystemObject")
    Application.ScreenUpdating = False  '关闭屏幕更新，加快程序运行
    Application.DisplayAlerts = False   '不显示警告信息
    
    With ActiveWorkbook  '拆分当前工作簿
        For Each sht In .Worksheets  '遍历所有工作表获取所有关键值
            If args_dict.Exists(sht.Name) Then  '如果工作表名未在参数字典中，则不拆分
                arr = sht.UsedRange: t = args_dict(sht.Name)(0): c = args_dict(sht.Name)(1)
                For i = t + 1 To UBound(arr)
                    If Len(arr(i, c)) > 0 Then dict(arr(i, c)) = ""  '关键值列不为空
                Next
            End If
        Next
        save_path = .path + "\拆分表"  '保存拆分后的表格保存路径
        wb_name = .Name  '当前工作簿文件名和扩展名
        If Not fso.FolderExists(save_path) Then fso.CreateFolder (save_path)  '创建文件夹
        For Each k In dict.keys
            Set write_wb = Workbooks.Add  '新建工作簿，拆分文件
            For Each sht In .Worksheets
                If args_dict.Exists(sht.Name) Then
                    sht.Copy After:=write_wb.Worksheets(write_wb.Worksheets.Count)
                    With write_wb.Worksheets(write_wb.Worksheets.Count)
                        arr = .UsedRange: t = args_dict(sht.Name)(0): c = args_dict(sht.Name)(1)
                        For i = t + 1 To UBound(arr)
                            If arr(i, c) <> k Then
                                If rng Is Nothing Then
                                    Set rng = .Rows(i)
                                Else
                                    Set rng = Union(rng, .Rows(i))
                                End If
                            End If
                        Next
                        rng.Delete: Set rng = Nothing  '删除非同一关键值的行，清空变量
                    End With
                End If
            Next
            write_wb.Worksheets(1).Delete  'excel新建wb第1个ws为空表
            '保存文件全名（文件路径、文件名、扩展名），keys命名
            file_name = RE_STR(CStr(k), "[\\/:*?""<>|]", "")  '删除文件名非法字符
            save_file = save_path & "\" & file_name & "." & fso.GetExtensionName(wb_name)
            write_wb.SaveAs filename:=save_file
            write_wb.Close (False)
        Next
    End With
    Application.ScreenUpdating  = True
    Application.DisplayAlerts = True
    Debug.Print "工作簿已拆分完成，累计用时" & Format(Timer - tm, "0.00")  '耗时
End Sub

Sub 工作表按列拆分_多列关键值()
    '当前工作表ws按固定多列的值拆分为多个工作表，文件保存在当前工作簿wb同一文件夹下单独文件夹内
    '采用删除法；关键值可单列、多列；可拆分为工作表或工作簿
    Dim arr, dict As Object, fso As Object, rng As Range, i&, t&, b&, bb&, k$, ws_name$, file_name$
'--------------------参数填写：key_col，列号数组，数字
    title_row = 1  '表头行，每个拆分后的sheet都保留
    key_col = Array(2, 4)  '关键值列，按该列的值进行拆分，相同的保存在同一ws
    delimiter = "_"    '分隔符，最好为数据中不存在的字符，如Chr(28)或|
    save_type = "wb"   '保存方式：ws拆分为工作表，wb拆分为工作簿
    ReDim temp(1 To UBound(key_col) - LBound(key_col) + 1)
    Set dict = CreateObject("scripting.dictionary"): tm = Timer
    Set fso = CreateObject("Scripting.FileSystemObject")
    Application.ScreenUpdating = False  '关闭屏幕更新，加快程序运行
    Application.DisplayAlerts = False   '不显示警告信息
    
    With ActiveSheet
        arr = .UsedRange: ReDim brr(1 To UBound(arr) - title_row)  'brr保存关键字
        For i = title_row + 1 To UBound(arr)  '遍历所有工作表获取所有关键值
            t = 0
            For Each c In key_col
                t = t + 1: temp(t) = arr(i, c)
            Next
            k = Join(temp, delimiter): b = b + 1: brr(b) = k
            dict(k) = ""
        Next
        If save_type = "ws" Then    '拆分为工作表
            For Each kk In dict.keys
                ws_name = Replace(kk, delimiter, "_")    '将分隔符改为下划线
                ws_name = RE_STR(ws_name, "[\\/:*?""<>|]", "")  '删除文件名非法字符
                .Copy after:=Worksheets(Worksheets.Count)  '复制到最后，keys命名
                With ActiveSheet
                    crr = .UsedRange: bb = 0: .Name = ws_name
                    For i = title_row + 1 To UBound(arr)
                        bb = bb + 1
                        If brr(bb) <> kk Then
                            If rng Is Nothing Then
                                Set rng = .Rows(i)
                            Else
                                Set rng = Union(rng, .Rows(i))
                            End If
                        End If
                    Next
                    rng.Delete: Set rng = Nothing  '删除非同一关键值的行，清空变量
                End With
            Next
        ElseIf save_type = "wb" Then    '拆分为工作簿
            save_path = .Parent.path + "\拆分表"  '保存拆分后的表格保存路径
            wb_name = .Parent.Name  '当前工作簿文件名和扩展名
            If Not fso.FolderExists(save_path) Then fso.CreateFolder (save_path)  '创建文件夹
            For Each kk In dict.keys
                Set write_wb = Workbooks.Add  '新建工作簿，拆分文件
                .Copy after:=write_wb.Worksheets(write_wb.Worksheets.Count)
                With write_wb.Worksheets(write_wb.Worksheets.Count)
                    crr = .UsedRange: bb = 0
                    For i = title_row + 1 To UBound(arr)
                        bb = bb + 1
                        If brr(bb) <> kk Then
                            If rng Is Nothing Then
                                Set rng = .Rows(i)
                            Else
                                Set rng = Union(rng, .Rows(i))
                            End If
                        End If
                    Next
                    rng.Delete: Set rng = Nothing  '删除非同一关键值的行，清空变量
                End With
                write_wb.Worksheets(1).Delete  'excel新建wb第1个ws为空表
                '保存文件全名（文件路径、文件名、扩展名），keys命名
                file_name = Replace(kk, delimiter, "_")    '将分隔符改为下划线
                file_name = RE_STR(file_name, "[\\/:*?""<>|]", "")  '删除文件名非法字符
                save_file = save_path & "\" & file_name & "." & fso.GetExtensionName(wb_name)
                write_wb.SaveAs filename:=save_file
                write_wb.Close (False)
            Next
        End If
    End With
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    Debug.Print "工作表已拆分完成，累计用时" & Format(Timer - tm, "0.00")  '耗时
End Sub