拆分工作簿为多个文件_能不能将总表快速拆分为多个工作簿？当然！

HI，大家好，我是星光。今天给大家分享的VBA常用小代码是 按指定字段将总表的数据拆分为多个工作簿。 举个栗子…… 如下图所示的数据表，倘若需要按班级，拆分为1~2~3班三个工作簿，并保留在电脑的指定位置，就可以使用我们今天这篇小代码了。
操作动画演示：
小贴士： 1，当选择拆分依据列时，可以选择整列，比如C列，也可以选择某列中的某个单元格以代替整列，例如C10单元格 2，代码可以保留总表的单元格格式、列宽行高等，但无法保留公式。 3，代码可以处理多行标题行，这是由以下选择框所决定的。如果总表没有标题行，则输入0。
示例代码如下。 代码如看不全，可以左右拖动..▼

Sub SplitWorkBooks()    Dim d As Object, sht As Worksheet    Dim aData, aResult, aTemp, aKeys, i&, j&, k&, x&    Dim rngData As Range, rngGist As Range    Dim lngTitleCount&, lngGistCol&, lngColCount&    Dim rngFormat As Range    Dim strKey As String, strPath As String    Set d = CreateObject("scripting.dictionary")    With Application.FileDialog(msoFileDialogFolderPicker)    '-------选择保存工作薄的文件路径         .AllowMultiSelect = False    '-------不允许多选         If .Show Then strPath = .SelectedItems(1) Else Exit Sub    End With    If Right(strPath, 1) <> "\" Then strPath = strPath & "\"    Set rngGist = Application.InputBox("请框选拆分依据列！只能选择单列单元格区域！", Title:="提示", Type:=8)    '-------用户选择的拆分依据列    lngGistCol = rngGist.Column    '-------拆分依据列的列标    lngTitleCount = Val(Application.InputBox("请输入总表标题行的行数？", , 1))    '-------用户设置总表的标题行数    If lngTitleCount < 0 Then MsgBox "标题行数不能为负数，程序退出。": Exit Sub    Set rngData = ActiveSheet.UsedRange    '-------总表的数据区域    Set rngFormat = ActiveSheet.Cells    '-------总表的单元格集用于粘贴总表格式    aData = rngData.Value    lngGistCol = lngGistCol - rngData.Column + 1    '-------计算依据列在数组中的位置    lngColCount = UBound(aData, 2)    '-------数据源的列数    For i = lngTitleCount + 1 To UBound(aData)        If aData(i, lngGistCol) = "" Then aData(i, lngGistCol) = "单元格空白"        strKey = aData(i, lngGistCol)    '-------统一转换为字符串格式        If Not d.exists(strKey) Then    '-------不存在关键字时将行号装入字典            d(strKey) = i        Else            d(strKey) = d(strKey) & "," & i    '-------如果存在关键字则合并行号        End If    Next    Application.DisplayAlerts = False    Application.ScreenUpdating = False    aKeys = d.keys    '-------字典的key集    For i = 0 To UBound(aKeys)        If aKeys(i) <> "" Then            aTemp = Split(d(aKeys(i)), ",")    '-------取出item里储存的行号            ReDim aResult(1 To UBound(aTemp) + 1, 1 To lngColCount)    '-------声明放置结果的数组aResult            k = 0            For x = 0 To UBound(aTemp)                k = k + 1                For j = 1 To lngColCount                    aResult(k, j) = aData(aTemp(x), j)                Next            Next            With Workbooks.Add    '-------新建一个工作簿                With Sheets(1).Range("a1")                    .Resize(UBound(aData), lngColCount).NumberFormat = "@"    '-------设置单元格为文本格式                    If lngTitleCount > 0 Then .Resize(lngTitleCount, lngColCount) = aData    '-------标题行                    .Offset(lngTitleCount, 0).Resize(k, lngColCount) = aResult    '-------数据                    rngFormat.Copy                    .PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False    '-------复制粘贴总表的格式                    .Offset(lngTitleCount + k, 0).Resize(UBound(aData) - k - lngTitleCount, 1).EntireRow.Delete    '-------删除多余的格式单元格                    .Select                End With                .SaveAs strPath & aKeys(i), xlWorkbookDefault                .Close True    '-------以默认excel版本保存新建的工作簿            End With        End If    Next    Application.DisplayAlerts = True    Application.ScreenUpdating = True    MsgBox "数据拆分完成！"    Set d = Nothing    Set rngData = Nothing    Set rngGist = Nothing    Set rngFormat = Nothing    Erase aData: Erase aResultEnd Sub

代码解析见注释，没啥需要额外补充的。

《VBA经典代码应用大全》 当当、天猫、京东均有销售~