亲宝软件园·资讯

展开

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

薛定谔_51 人气:0

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

对Excel表格数据按照某列的值,将工作表拆分

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

单列关键值

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,复制法

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

举例

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

在这里插入图片描述

工作簿拆分结果

在这里插入图片描述

在这里插入图片描述

3.2,删除法

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

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

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

如果需要对数据按多列关键值合并进行拆分,可以选择添加辅助列,先将多列的值合并,在使用以上sub进行拆分;也可以重新定义一个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

注意:

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

在这里插入图片描述

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

举例

原始数据

在这里插入图片描述

拆分为工作簿

在这里插入图片描述

加载全部内容

相关教程
猜你喜欢
用户评论