Excel·VBA按列拆分工作表

如果需要对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），文件单独保存
    tm = Now()
    Application.Visible = False  '后台运行，不显示界面
    Application.DisplayAlerts = False  '不显示警告信息
    Dim arr, dict As Object
    Set dict = CreateObject("scripting.dictionary")
    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 fso.FolderExists(save_path) Then
        Debug.Print ("拆分文件保存路径已存在：" & save_path)
    Else
        fso.CreateFolder (save_path)
        Debug.Print ("拆分文件保存路径已创建：" & save_path)
    End If
    
    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.Visible = True
    Application.DisplayAlerts = True
    Debug.Print ("工作表已拆分完成，累计用时" & Format(Now() - tm, "hh:mm:ss"))  '耗时

End Sub