Excel·VBA工作表整列拆分为工作簿

不同于《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
            Set rng = Nothing
            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，结果