HI，各位亲，
今天我们分享VBA常用小代码第10篇，按指定字段将总表的数据拆分为多个分表工作簿。
举个栗子，如上图所示的数据表，倘若需要按班级，将该表的数据拆分为1~2~3班三个工作簿，并保留在电脑的指定位置，就可以使用我们今天这篇小代码了。
操作动画演示：
代码比较长，建议新手收藏后用到时会复制粘贴运行就好。
Sub Newbooks()
Dim d As Object, arr, brr, r, kr, i&, j&, k&, x&
Dim Rng As Range, Rg As Range, tRow&, tCol&, aCol&, pd&, mypath$
Dim Cll As Range, sht As Worksheet
Application.ScreenUpdating = False
'取消屏幕刷新
Application.DisplayAlerts = False
'取消警告信息提醒，当有重名工作簿时直接覆盖保存。
'
'
'第一部分，用户选择保存分表工作簿的路径。
With Application.FileDialog(msoFileDialogFolderPicker)
'选择保存工作薄的文件路径
.AllowMultiSelect = False
'不允许多选
If .Show Then
mypath = .SelectedItems(1)
'读取选择的文件路径
Else
Exit Sub
'如果没有选择保存路径，则退出程序
End If
End With
If Right(mypath, 1) <> "\" Then mypath = mypath & "\"
'
'
'第二部分遍历总表数据，通过字典将指定字段的不同明细行过滤保存
Set d = CreateObject("scripting.dictionary") 'set字典
Set Rg = Application.InputBox("请框选拆分依据列！只能选择单列单元格区域！", Title:="提示", Type:=8)
'用户选择的拆分依据列
tCol = Rg.Column
'取拆分依据列列标
tRow = Val(Application.InputBox("请输入总表标题行的行数？"))
'用户设置总表的标题行数
If tRow = 0 Then MsgBox "你未输入标题行行数，程序退出。": Exit Sub
Set Rng = ActiveSheet.UsedRange
'总表的数据区域
Set Cll = ActiveSheet.Cells
'用于在分表粘贴和总表同样行高列宽的数据格式
arr = Rng
'数据范围装入数组arr
tCol = tCol - Rng.Column + 1
'计算依据列在数组中的位置
aCol = UBound(arr, 2)
'数据源的列数
For i = tRow + 1 To UBound(arr)
'遍历数组arr
If Not d.exists(arr(i, tCol)) Then
d(arr(i, tCol)) = i
'字典中不存在关键词则将行号装入字典
