Excel·VBA按列拆分工作表、工作簿

1，工作表按列拆分为工作表

改进《将excel按照某一列拆分成多个文件》，使代码更具通用性，可以实现将工作表拆分为工作表或工作簿，仅支持单列关键值

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

2，工作表按列拆分为工作簿

单列关键值

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

1、2举例

原始数据

拆分为工作表


拆分为工作薄

3，工作簿按列拆分

对包含多个工作表的工作簿进行拆分，支持每个工作表中关键值列号都不同（单列关键值）

3.1，复制法

Function RE_STR(ByVal source_str$, pat$, Optional replace_str$ = "$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

举例

1个工作簿中有3个工作表，需要按照“属地”所在列的值拆分整个工作簿

工作簿拆分结果

3.2，删除法

以上工作簿按列拆分采用的是复制数据的方法，以下为删除法，删除非同一关键值的行。
经测试，删除法比原本的复制法快2倍以上，尤其是使用先Union行再删除的方法

2023.4.17更新，应评论建议
为避免某个工作表仅存在单一关键值而无需执行删除操作导致报错的，更新增加if判断以避免
同时在某个工作表执行删除操作后仅有表头行的空表情况，更新增加删除此类空表

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
                        '删除非同一关键值的行，清空变量；删除仅有表头的空表
                        If Not rng Is Nothing Then rng.Delete: Set rng = Nothing
                        If .UsedRange.Rows.Count = t Then .Delete
                    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

4，工作表按列拆分，支持多列关键值

如果需要对数据按多列关键值合并进行拆分，可以选择添加辅助列，先将多列的值合并，在使用以上sub进行拆分；也可以重新定义一个sub既支持单列又支持多列关键值的

2023.4.29更新，应评论建议
对工作表拆分为工作簿，每个wb都保留指定名称的ws，以保证拆分后的表格内公式正常使用，经测试表1中vlookup可以正常获取表2的结果

Sub 工作表按列拆分_多列关键值()
    '当前工作表ws按固定多列的值拆分为多个工作表，文件保存在当前工作簿wb同一文件夹下单独文件夹内
    '采用删除法；关键值可单列、多列；可拆分为工作表或工作簿；增加拆分为wb固定保留指定ws
    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拆分为工作簿
    keep_ws = Array("数据源")  '拆分为wb，需固定保留指定ws名称，无需保留的参数为空数组
    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 + "拆分表"  '保存拆分后的表格保存路径
            ws_name = .Name: wb_name = .Parent.Name  '当前ws、wb名称
            If Not fso.FolderExists(save_path) Then fso.CreateFolder (save_path)  '创建文件夹
            For Each kk In dict.keys
                If UBound(keep_ws) = -1 Then  '无需保留固定ws
                    .Copy    'ws在copy后自动生成一个新建wb
                Else
                    s = Join(keep_ws, Chr(28)) & Chr(28) & ws_name  '字符串拼接
                    srr = Split(s, Chr(28))  '需复制的ws名称数组
                    .Parent.Worksheets(srr).Copy  '工作表整体复制
                End If
                With ActiveWorkbook.Worksheets(ws_name)
                    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
                '保存文件全名（文件路径、文件名、扩展名），keys命名
                file_name = Replace(kk, delimiter, "_")    '将分隔符改为下划线
                file_name = RE_STR(file_name, "[\/:*?""<>|]", "")  '删除文件名非法字符
                save_file = save_path & "" & file_name & "." & fso.GetExtensionName(wb_name)
                ActiveWorkbook.SaveAs filename:=save_file
                ActiveWorkbook.Close (False)
            Next
        End If
    End With
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    Debug.Print "工作表已拆分完成，累计用时" & Format(Timer - tm, "0.00")  '耗时
End Sub

注意：
关键值列最好不存在为空的单元格，如果分隔符delimiter也为空的话，可能导致关键值错误进而拆分错误，比如

b1和c1为空值，textjoin分隔符为空则导致关键值d1和d2相同，为避免这种情况delimiter最好不为空，且为数据中不存在的字符，避免最后replace导致保存文件名出错

举例

原始数据

拆分为工作簿

最后

以上就是健忘导师为你收集整理的Excel·VBA按列拆分工作表、工作簿的全部内容，希望文章能够帮你解决Excel·VBA按列拆分工作表、工作簿所遇到的程序开发问题。

如果觉得靠谱客网站的内容还不错，欢迎将靠谱客网站推荐给程序员好友。