Sub 工作表按列拆分為工作表()
    '當(dāng)前工作表（worksheet）按固定某列的值拆分為多個工作表，保存在當(dāng)前工作簿（workbook）
    Dim arr, dict As Object
    Set dict = CreateObject("scripting.dictionary")
'--------------------參數(shù)填寫：num_col，數(shù)字，A列為1向右遞增；title_row，數(shù)字，第1行為1向下遞增
    num_col = 4  '關(guān)鍵值列，按該列的值進(jìn)行拆分，相同的保存在同一ws
    title_row = 1  '表頭行，每個拆分后的sheet都保留
    Set ws = Application.ActiveSheet
    arr = ActiveSheet.UsedRange  '所有數(shù)據(jù)行讀取為數(shù)組，也可arr = [a1].CurrentRegion
    
    For i = title_row + 1 To UBound(arr):  '遍歷關(guān)鍵值列，寫入字典，key為關(guān)鍵值，item為對應(yīng)的行
        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:  '遍歷字典，創(chuàng)建、寫入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  '復(fù)制列寬
            ws.Rows(1 & ":" & title_row).Copy .[a1]  '復(fù)制表頭
            v(i).Copy .Range("A" & title_row + 1)  '復(fù)制數(shù)據(jù)
        End With
        'Exit For  '強制退出for循環(huán)，單次測試使用
    Next
End Sub

Sub 工作表按列拆分為工作簿()
    '當(dāng)前工作表（worksheet）按固定某列的值拆分為多個工作簿（workbook），文件單獨保存
    Dim arr, dict As Object
    Set dict = CreateObject("scripting.dictionary"): tm = Timer
    Set fso = CreateObject("Scripting.FileSystemObject")
'--------------------參數(shù)填寫：num_col，數(shù)字，A列為1向右遞增；title_row，數(shù)字，第1行為1向下遞增
    num_col = 4  '關(guān)鍵值列，按該列的值進(jìn)行拆分，相同的保存在同一ws
    title_row = 1  '表頭行，每個拆分后的sheet都保留
    Set ws = Application.ActiveSheet
    wb_path = Application.ActiveWorkbook.Path  '當(dāng)前工作簿文件路徑
    wb_name = Application.ActiveWorkbook.Name  '當(dāng)前工作簿文件名和擴(kuò)展名
    save_path = wb_path + "\拆分表"  '保存拆分后的表格保存路徑
    If Not fso.FolderExists(save_path) Then fso.CreateFolder (save_path)  '創(chuàng)建文件夾
    Application.ScreenUpdating = False  '關(guān)閉屏幕更新，加快程序運行
    Application.DisplayAlerts = False   '不顯示警告信息
    
    arr = ActiveSheet.UsedRange  '所有數(shù)據(jù)行讀取為數(shù)組，也可arr = [a1].CurrentRegion
    For i = title_row + 1 To UBound(arr):  '遍歷關(guān)鍵值列，寫入字典，key為關(guān)鍵值，item為對應(yīng)的行
        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:  '遍歷字典，創(chuàng)建、寫入wb
        Workbooks.Add
        With ActiveSheet
            ws.Rows(1).Copy
            .[a1].PasteSpecial Paste:=xlPasteColumnWidths  '復(fù)制列寬
            ws.Rows(1 & ":" & title_row).Copy .[a1]  '復(fù)制表頭
            v(i).Copy .Range("A" & title_row + 1)  '復(fù)制數(shù)據(jù)
        End With
        '保存文件全名（文件路徑、文件名、擴(kuò)展名），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循環(huán)，單次測試使用
    Next
    
    Set fso = Nothing  '釋放內(nèi)存
    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")
    '通用正則替換函數(shù)，函數(shù)定義RE(字符串，正則模式，替換值)對單元格返回正則替換后的字符串
    With CreateObject("vbscript.regexp")  '正則表達(dá)式
        .Global = True
        .Pattern = pat
        RE_STR = .Replace(source_str, replace_str)
    End With
End Function

Sub 工作簿按列拆分()
    '當(dāng)前工作簿wb所有工作表ws按一列的值拆分為多個工作簿，新舊工作簿形式一致，以列值命名新wb
    Dim arr, dict As Object, fso As Object, title_row&, num_col&, i&
'--------------------參數(shù)填寫：num_col，數(shù)字，A列為1向右遞增；title_row，數(shù)字，第1行為1向下遞增
    title_row = 1  '表頭行，每個拆分后的sheet都保留
    num_col = 0    '關(guān)鍵值列，按該列的值進(jìn)行拆分，相同的保存在同一ws，為0時使用key_col
    key_col = "屬地"  '首行關(guān)鍵值，當(dāng)各工作表關(guān)鍵值列號不同時，使用關(guān)鍵值動態(tài)確定num_col（初始為0）
    Set dict = CreateObject("scripting.dictionary"): tm = Timer
    Set fso = CreateObject("Scripting.FileSystemObject")
    Application.ScreenUpdating = False  '關(guān)閉屏幕更新，加快程序運行
    Application.DisplayAlerts = False   '不顯示警告信息
    
    With ActiveWorkbook  '拆分當(dāng)前工作簿
        save_path = .path + "\拆分表"  '保存拆分后的表格保存路徑
        wb_name = .Name  '當(dāng)前工作簿文件名和擴(kuò)展名
        If Not fso.FolderExists(save_path) Then fso.CreateFolder (save_path)  '創(chuàng)建文件夾
        For Each sht In .Worksheets
            If num_col > 0 Then
                col = num_col
            ElseIf num_col = 0 Then  '為0時使用key_col動態(tài)確定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)  '遍歷關(guān)鍵值列，寫入字典，key為關(guān)鍵值，item為對應(yīng)的行
                If Len(arr(i, col)) > 0 Then      '關(guān)鍵值列不為空
                    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:  '遍歷字典，創(chuàng)建、寫入wb
                Workbooks.Add
                With ActiveSheet
                    .Name = sht.Name  '工作表命名
                    sht.Rows(1).Copy
                    .[a1].PasteSpecial Paste:=xlPasteColumnWidths  '復(fù)制列寬
                    sht.Rows(1 & ":" & title_row).Copy .[a1]       '復(fù)制表頭
                    v(i).Copy .Range("A" & title_row + 1)          '復(fù)制數(shù)據(jù)
                End With
                Set ws = Application.ActiveSheet
                '保存文件全名（文件路徑、文件名、擴(kuò)展名），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  '文件不存在，創(chuàng)建
                    ActiveWorkbook.SaveAs filename:=save_file
                    ActiveWorkbook.Close (False)
                Else  '文件存在，復(fù)制
                    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 工作簿按列拆分_刪除法()
    '當(dāng)前工作簿wb所有工作表ws按一列的值拆分為多個工作簿，新舊工作簿形式一致，以列值命名新wb
    '采用刪除非同一關(guān)鍵值的方法；同時使用字典定義參數(shù)，可實現(xiàn)每個ws表頭行數(shù)與關(guān)鍵值列號都不同
    Dim arr, args_dict As Object, dict As Object, fso As Object, rng As Range, t&, c&, i&
    Set args_dict = CreateObject("scripting.dictionary")  '參數(shù)字典
'--------------------參數(shù)填寫：字典(工作表名)= Array(表頭行數(shù), 關(guān)鍵值列號)；如果工作表名未在字典中，則不拆分
    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  '關(guān)閉屏幕更新，加快程序運行
    Application.DisplayAlerts = False   '不顯示警告信息
    
    With ActiveWorkbook  '拆分當(dāng)前工作簿
        For Each sht In .Worksheets  '遍歷所有工作表獲取所有關(guān)鍵值
            If args_dict.Exists(sht.Name) Then  '如果工作表名未在參數(shù)字典中，則不拆分
                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)) = ""  '關(guān)鍵值列不為空
                Next
            End If
        Next
        save_path = .path + "\拆分表"  '保存拆分后的表格保存路徑
        wb_name = .Name  '當(dāng)前工作簿文件名和擴(kuò)展名
        If Not fso.FolderExists(save_path) Then fso.CreateFolder (save_path)  '創(chuàng)建文件夾
        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  '刪除非同一關(guān)鍵值的行，清空變量
                    End With
                End If
            Next
            write_wb.Worksheets(1).Delete  'excel新建wb第1個ws為空表
            '保存文件全名（文件路徑、文件名、擴(kuò)展名），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 工作表按列拆分_多列關(guān)鍵值()
    '當(dāng)前工作表ws按固定多列的值拆分為多個工作表，文件保存在當(dāng)前工作簿wb同一文件夾下單獨文件夾內(nèi)
    '采用刪除法；關(guān)鍵值可單列、多列；可拆分為工作表或工作簿
    Dim arr, dict As Object, fso As Object, rng As Range, i&, t&, b&, bb&, k$, ws_name$, file_name$
'--------------------參數(shù)填寫：key_col，列號數(shù)組，數(shù)字
    title_row = 1  '表頭行，每個拆分后的sheet都保留
    key_col = Array(2, 4)  '關(guān)鍵值列，按該列的值進(jìn)行拆分，相同的保存在同一ws
    delimiter = "_"    '分隔符，最好為數(shù)據(jù)中不存在的字符，如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  '關(guān)閉屏幕更新，加快程序運行
    Application.DisplayAlerts = False   '不顯示警告信息
    
    With ActiveSheet
        arr = .UsedRange: ReDim brr(1 To UBound(arr) - title_row)  'brr保存關(guān)鍵字
        For i = title_row + 1 To UBound(arr)  '遍歷所有工作表獲取所有關(guān)鍵值
            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)  '復(fù)制到最后，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  '刪除非同一關(guān)鍵值的行，清空變量
                End With
            Next
        ElseIf save_type = "wb" Then    '拆分為工作簿
            save_path = .Parent.path + "\拆分表"  '保存拆分后的表格保存路徑
            wb_name = .Parent.Name  '當(dāng)前工作簿文件名和擴(kuò)展名
            If Not fso.FolderExists(save_path) Then fso.CreateFolder (save_path)  '創(chuàng)建文件夾
            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  '刪除非同一關(guān)鍵值的行，清空變量
                End With
                write_wb.Worksheets(1).Delete  'excel新建wb第1個ws為空表
                '保存文件全名（文件路徑、文件名、擴(kuò)展名），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