excel、wps 使用vba实现按内容拆分工作表

这是计算机选手初学vba的现场。

操作说明

将代码放入需要拆分的工作簿，并在目标工作表选中要拆分的列，

注意事项

需要先选中需要拆分的数据列，否则会报错

代码

'按内容拆分工作簿并调整格式
Dim 拆分列, rowNum, iserr%, index_col As Long
Sub 拆分工作簿()
'
' 拆分工作簿 Macro
'
    Dim Data, col, i As Long, j As Long, TargetCount As Long, RowCount As Long ', WBName%
    Dim ActiveWB As String, PathStr As String, arr
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Call 拆分列_不重复值   '获取列的不重复值-返回数组：拆分列
    If iserr = 1 Then iserr = 0: Exit Sub '取消退出
    ActiveWB = ActiveWorkbook.Name
    Call 获取文件夹路径(PathStr)  '获取文件夹的存储路径
    'WBName = Application.InputBox("请输入文件名后缀：", "操作提示！", "2023年7月销售统计", , , , , 2) '报错：类型不匹配
    'If WBName = False Then iserr = 1: Exit Sub  '如果点击了取消按钮，则退出过程。
    On Error Resume Next '后续出错，程序不中断
    
    Data = Range("A1").CurrentRegion.Value  '待拆分数据写入数组data
    col = Range("A1:" & Replace(Cells(1, UBound(Data, 2)).Address(False, False), "1", "") & rowNum).Value  '数据标题行写入数组data
    ReDim arr(1 To UBound(col, 2), 1 To 1)
    For i = 0 To UBound(拆分列)
        TargetCount = 0
        For RowCount = 2 To UBound(Data)
            If CStr(Data(RowCount, index_col)) = 拆分列(i) Then
                TargetCount = TargetCount + 1
                ReDim Preserve arr(1 To UBound(col, 2), 1 To TargetCount)
                For j = 1 To UBound(col, 2)
                    arr(j, TargetCount) = Data(RowCount, j)
                Next
            End If
        Next
        If TargetCount > 0 Then
            Workbooks.Add
            With ActiveWorkbook
                With .Sheets(1)
                    .Name = 拆分列(i) & "7月发货明细"
                    .Range("A1:" & Replace(Cells(1, UBound(Data, 2)).Address(False, False), "1", "") & rowNum) = col
                    .Range("a" & (rowNum + 1)).Resize(TargetCount, UBound(col, 2)) = WorksheetFunction.Transpose(arr)
                    
                    Workbooks(ActiveWB).Activate              '复制原数据表的格式
                    Sheets(1).UsedRange.Select
                    Selection.Copy
                    
                    .Activate                                 '粘贴原数据表的格式
                    .UsedRange.Select
                    Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
                    Call 调整格式
                End With
                .SaveAs Filename:=PathStr & 拆分列(i) & "-2023年7月销售统计" & IIf(Application.Version * 1 < 12, ".xls", ".xlsx"), FileFormat:=xlWorkbookDefault, CreateBackup:=False
                .Close
            End With
            Erase arr
            Workbooks(ActiveWB).Activate
        End If
    Next
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
    MsgBox "已拆分完成" & VBA.Chr(10) & "共拆分为：" & UBound(拆分列) + 1 & " 个工作簿！", vbInformation, "操作提示！"
End Sub

Private Sub 拆分列_不重复值() ' 返回去重后的数组
    Dim myRng As Range, arr1, i As Long, d1, n%
    If Intersect(ActiveWindow.RangeSelection, ActiveSheet.UsedRange) Is Nothing Then MsgBox "未选择，做为拆分依据的列！", vbQuestion, "提示": iserr = 1: Exit Sub
    Set myRng = Intersect(ActiveWindow.RangeSelection, ActiveSheet.UsedRange)
    index_col = myRng.Column
    n = Application.InputBox("请输入标题行数，标题行不参与拆分：", "操作提示！", 1, , , , , 1)  '注意n 不需要设置数据类型，数据类型已在参数里最后一位数字设置好了。
    If n = False Then iserr = 1: Exit Sub  '如果点击了取消按钮，则退出过程。
    arr1 = myRng
    Set d1 = CreateObject("Scripting.Dictionary")
    For i = 1 + n To myRng.Count
        d1(Trim(arr1(i, 1))) = ""  '关键字写入字典，去重（一个key对应唯一item，item可重复）
    Next
    拆分列 = d1.Keys
    rowNum = n
End Sub

Private Sub 获取文件夹路径(PathStr As String)
    With Application.FileDialog(msoFileDialogFolderPicker)
        If .Show Then
            PathStr = .SelectedItems(1)
        Else
            Exit Sub
        End If
    End With
    PathStr = PathStr & IIf(Right(PathStr, 1) = "\", "", "\")
End Sub

Private Sub 调整格式()
'
' 调整格式 Macro
'
    Range("A1:N1").Merge Across:=True '第一行合并并居中
    With Range("A1:N155")
        .IndentLevel = 0  '缩进值
        .WrapText = True '自动换行
    End With
    With Range("A1:N1").Font
        .Name = "Microsoft YaHei"
        .Size = 16
        .Bold = True '加粗
    End With
    With Range("A2:N2").Font
        .Name = "Microsoft YaHei"
        .Size = 11
        .Bold = True
    End With
    With Range("A3:N155").Font
        .Name = "Microsoft YaHei"
        .Size = 10
    End With
    With Range("A1:N155")
        .VerticalAlignment = xlVAlignCenter
        .HorizontalAlignment = xlHAlignCenter
    End With
    With Range("B3:F155")
        .HorizontalAlignment = xlHAlignLeft
    End With
    With Range("M3:M155")
        .HorizontalAlignment = xlHAlignLeft
    End With
    Range("A1:N1").RowHeight = 24.5
    Selection.RowHeight = 18.5

    '设置自动列宽
    Selection.EntireColumn.AutoFit
    Selection.EntireRow.AutoFit
End Sub