能不能将总表快速拆分为多个工作簿？

有一盏离愁孤灯伫立在窗口 我在门后假装你人还没走 ……

诸君好，今天我们分享VBA常用小代码工作表部分的第10篇，按指定字段将总表的数据拆分为多个工作簿。

举个栗子……

如下图所示的数据表，倘若需要按班级，拆分为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 aResult
End Sub