excel如何拆分工作簿——VBA实现

用VBA实现

Sub 拆分工作簿()
    Application.ScreenUpdating = False '关闭屏幕闪动，提速
    Application.DisplayAlerts = False '关闭窗口提示
    kk = 2
    Set dic = CreateObject("scripting.dictionary")
    With ThisWorkbook.Worksheets("Sheet1") '根据自己的工作簿自行修改
        cln = InputBox("请输入需要按列拆分的列:" & Chr(10) & "英文列标", "输入列标", "A") 'inputbox提示输入需要拆分的列标
        cln2 = .Range("a1").End(xlToRight).Column '获取最大列数，为了增加通用性
        If .Range(cln & 2) = "" Then Exit Sub
        rrow = .Cells(Rows.Count, cln).End(xlUp).Row
        arr = WorksheetFunction.Transpose(.Range(cln & 1 & ":" & cln & rrow))
        For i = 1 To UBound(arr)  '将拆分条件列数据写入字典，为了去重复。
            If Not dic.exists(arr(i)) Then '若字典中不存在该字符串，则写入。
            dic.Add arr(i), .Range("a" & i).Resize(1, cln2)
        Else
            Set dic.Item(arr(i)) = Union(dic.Item(arr(i)), .Range("a" & i).Resize(1, cln2))
        End If
    Next
    k = dic.keys
    l = dic.items
    For ss = 0 To dic.Count - 1
        Set wb = Workbooks.Add '新建工作簿
        With wb.Worksheets(1)
            Rows(1).Copy ActiveSheet.Rows(1)
            'l(ss).Copy .Range("a2")
            l(ss).Copy .Range("a2")
            ActiveSheet.Columns("D:D").ColumnWidth = 51
            ActiveSheet.Rows("2:100").EntireRow.AutoFit
            ActiveSheet.Columns("A:C").EntireColumn.AutoFit
            ActiveSheet.Columns("E:P").EntireColumn.AutoFit
            ActiveSheet.Columns("J:J").ColumnWidth = 33
            'Sheets(1).Range("a2:a100").PasteSpecial Paste:=xlPasteFormats
            'Worksheets("Sheet1").Range("a1:m1").Copy.Range ("a1:m1")
        End With
        wb.SaveAs "D:\" & k(ss) & ".xlsx" '将新建的工作簿保存在代码工作簿下
        wb.Close True '关闭工作簿，并保存
        Set wb = Nothing '释放内存
    Next
    End With
Application.ScreenUpdating = True
Application.DisplayAlerts = True
MsgBox "完成"
End Sub