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

1，工作表按固定列数，整列拆分为工作簿

看到一个帖子《CSDN-EXCEL按列进行拆分》
不同于《Excel·VBA按列拆分工作表、工作簿》按某列的值对工作表拆分，仅按固定列数拆分工作表单独保存为工作簿，类似于《Excel·VBA按行拆分工作表》

Sub 工作表整列拆分为工作簿()
    '当前工作表ws按固定列数整列拆分为多个工作簿，文件保存在当前工作簿wb同一文件夹下单独文件夹内
    '保存文件夹以wb命名，拆分后的wb以拆分列首行内容命名；ws开头行列不能为空
    Dim arr, fso As Object, title_rng As Range, rng As Range, save_path$, file_name$
    Dim title_col&, num_col&, i&
'--------------------参数填写：title_col、num_col，大于0的整数
    title_col = 1    '表头列数，每个拆分后的sheet都保留
    num_col = 1    '固定拆分列数，整列拆分，不能完全拆分的，多余列数单独
    Set fso = CreateObject("Scripting.FileSystemObject"): tm = Timer
    Application.ScreenUpdating = False  '关闭屏幕更新，加快程序运行
    Application.DisplayAlerts = False   '不显示警告信息
    
    With ActiveSheet
        ws_name = .Name: save_path = .Parent.path & "\拆分表\"  '保存拆分后的表格保存路径
        If Not fso.FolderExists(save_path) Then fso.CreateFolder (save_path)  '创建文件夹
        max_row = .UsedRange.Rows.Count: max_col = .UsedRange.Columns.Count
        Set title_rng = .Cells(1, 1).Resize(max_row, title_col)
        For i = title_col + 1 To max_col Step num_col
            If num_col > 1 Then
                arr = .Cells(1, i).Resize(1, num_col)
                arr = WorksheetFunction.Transpose(WorksheetFunction.Transpose(arr))
                file_name = Join(arr, "") & ".xlsx"
            ElseIf num_col = 1 Then
                file_name = .Cells(1, i) & ".xlsx"
            End If
            Set rng = Union(title_rng, .Cells(1, i).Resize(max_row, num_col))
            Set write_wb = Workbooks.Add  '新建工作簿，拆分文件
            With ActiveSheet
                .Name = ws_name
                rng.Copy .Cells(1, 1)
            End With
            write_wb.SaveAs filename:=save_path & file_name
            write_wb.Close (False)
        Next
    End With
    Application.ScreenUpdating = True: Application.DisplayAlerts = True
    Debug.Print "工作表已拆分完成，累计用时" & Format(Timer - tm, "0.00")  '耗时
End Sub

举例

• 参数：表头列数title_col = 1、按每1列拆分num_col = 1，结果
  
• 参数：表头列数title_col = 1、按每2列拆分num_col = 2，结果
  

2，工作簿按单行值，整列拆分为工作簿

与《Excel·VBA按列拆分工作表、工作簿》3，工作簿按列拆分按某一列的值对相同的值的整行拆分为一个工作簿类似；按某一行的值对相同的值的整列拆分为一个工作簿，因此代码比较类似

Sub 工作簿按单行值整列拆分()
    '当前工作簿wb所有工作表ws按指定行的值拆分为多个工作簿，新旧工作簿形式一致，以列值命名新wb
    Dim arr, args_dict As Object, dict As Object, fso As Object, rng As Range, t&, e&, r&, i&
    Dim sht As Worksheet, write_wb As Workbook, save_path$, file_name$, srr, k
    Set args_dict = CreateObject("scripting.dictionary")  '参数字典
'--------------------参数填写：字典(工作表名)= Array(表头列数, 表尾列数, 关键值行号)；如果工作表名未在字典中，则不拆分
    args_dict("应发工资") = Array(2, 1, 2): args_dict("发放人次") = Array(2, 1, 2)
    args_dict("工资水平") = Array(2, 1, 2)
    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): e = args_dict(sht.Name)(1): r = args_dict(sht.Name)(2)
                For i = t + 1 To UBound(arr, 2) - e
                    If TypeName(arr(r, i)) <> "Error" Then
                        If Len(arr(r, i)) > 0 Then dict(arr(r, i)) = ""  '关键值列不为空
                    End If
                Next
            End If
        Next
        save_path = .path + "\拆分表\"  '保存拆分后的表格保存路径
        srr = args_dict.keys  '需要拆分的工作表名称数组，注意args_dict中不能有工作簿中不存在的工作表
        If Not fso.FolderExists(save_path) Then fso.CreateFolder (save_path)  '创建文件夹
        For Each k In dict.keys
            .Worksheets(srr).Copy  '整体复制工作表
            With ActiveWorkbook
                For Each sht In .Worksheets
                    arr = sht.UsedRange
                    t = args_dict(sht.Name)(0): e = args_dict(sht.Name)(1): r = args_dict(sht.Name)(2)
                    For i = t + 1 To UBound(arr, 2) - e
                        If TypeName(arr(r, i)) = "Error" Then arr(r, i) = ""  '错误值改为空值，便于判断拆分
                        If arr(r, i) <> k Then
                            If rng Is Nothing Then
                                Set rng = sht.Columns(i)
                            Else
                                Set rng = Union(rng, sht.Columns(i))
                            End If
                        End If
                    Next
                    '删除非同一关键值的行，清空变量；删除仅有表头的空表
                    If Not rng Is Nothing Then rng.Delete: Set rng = Nothing
                    If sht.UsedRange.Rows.Count = t Then sht.Delete
                Next
                .SaveAs filename:=save_path & k & ".xlsx"  '保存文件全名（文件路径、文件名、扩展名），keys命名
                .Close (False)
            End With
        Next
    End With
    Application.ScreenUpdating = True: Application.DisplayAlerts = True
    Debug.Print "工作簿已拆分完成，累计用时" & Format(Timer - tm, "0.00")  '耗时
End Sub

举例

工作簿中3个工作表样式相同，因此参数args_dict的值相同

• 参数args_dict的值为Array(2, 1, 2)，拆分后保留“合计”列，结果生成A、B、C共3个工作簿
  
• 参数args_dict的值为Array(2, 0, 2)，拆分后不保留“合计”列，结果生成A、B、C共3个工作簿
  
  这是由于最后一列“合计”列的关键值行号为2时，该位置L2为合并单元格，实际为空值，在代码中Len(arr(r, i)) > 0处忽略了空值不进行拆分，使用代码时应当注意