开发者

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

目录
  • 1,工作表按列拆分为工作表
  • 2,工作表按列拆分为工作簿
  • 3,工作簿按列拆分
    • 3.1,复制法
    • 3.2,删除法
  • 4,工作表按列拆分,支持多列关键值

    改进《将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
      php  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举例

    原始数据

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

    拆分为工作表

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

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

    拆分为工作薄

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

    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 = "属地javascript"  '首行关键值,当各工作表关键值列号不同时,使用关键值动态确定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个工作表,需要按照“属地”所在列的值拆分整个工作簿

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

    工作簿拆分结果

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

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

    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)) = ""  '关键值列不为javascript空
                    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也为空的话,可能导致关键值错误进而拆分错误,比如

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

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

    举例

    原始数据

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

    拆分为工作簿

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

    到此这篇关于Excel·VBA按列拆分工作表和工作簿的实现的文章就介绍到这了,更多相关Excel VBA按列拆分内容请搜索我们以前的文章或继续浏览下面的相关文章希望大家以后多多支持我们!

    0

    上一篇:

    下一篇:

    精彩评论

    暂无评论...
    验证码 换一张
    取 消

    最新开发

    开发排行榜