前言：工作簿数据的拆分，有各种各样的需求，本示例介绍其中的一种需求实现，后续将会陆续补充相关内容。
借鉴此示例，你可以将信贷台账等按机构拆分开来，总之，举一返三，这方面的应用不时都会用到。
用循环嵌套速度慢，用数组 字典的方式处理速度会快很多。经测试，5万笔数据，132列，用时23秒完成拆分。
数据源：
结果：
Code:
"function:将当前工作表按第2列中的关键字拆分为各个不同的工作簿
"需要在VBE工具-引用中添加windows script Host Object Model
Sub SplitSht()
"变量声明
Dim tm, Fso As FileSystemObject, sfolder$, wb As Workbook, arr
Dim rng As Range, lastRow&, lastCol%, d As Object, k, t, sh As Worksheet, i&
tm = Timer "计时开始
"创建文件系统对象
Set Fso = CreateObject("Scripting.FileSystemObject")
"在当前文件夹中创建一个子目录用于存放拆分好的工作簿文件
sfolder = ThisWorkbook.Path & "分表"
"若子目录不存在，创建之
If Fso.FolderExists(sfolder) = False Then Fso.CreateFolder sfolder
"关闭屏幕更新，防止闪屏，加快处理速度
Application.ScreenUpdating = False
"关闭使用工作簿的 SaveAs 方法覆盖现有文件，“覆盖”警告默认为“No”
"当 DisplayAlerts 属性设置等于 False 时，Excel 选择“Yes”响应。
Application.DisplayAlerts = False
"对Sheet1表进行操作，可据实修改
With Sheets("Sheet1")
"将Sheet1表单元格区域A1:C1（字段名）赋给对象变量rng
Set rng = .Range("A1:EB1")
"取B列最后一个有数据的单元格所在行行号赋给变量lastRow
lastRow = .Range("B" & Rows.Count).End(xlUp).Row
"根据不同的Office版本（2007为12.0），取第一行最后一个有数据的单元格所在列列号赋给变量 lastCol
If Application.Version >= "12.0" Then
lastCol = .Range("XFD1").End(xlToLeft).Column
Else
lastCol = .Range("IV1").End(xlToLeft).Column
End If
"将关键字所在列中B1到B列最后一个有数据的单元格组成的区域赋给数组arr
"实际运用中关键字所在列据实修改
arr = .Range("B2:B" & lastRow)
"创建字典对象
Set d = CreateObject("scripting.dictionary")
" Debug.Print UBound(arr)
"循环，从1到数组arr第一维最大下标
For i = 1 To UBound(arr)
"如果字典中不存在arr(i, 1)对应的关键字,则
If Not d.Exists(arr(i, 1)) Then
"首次循环时，条目为单元格A2向右扩展1行3列的单元格区域即A2:D2
"i要加1是因为首次代入的变量为1，加1后变为2， Cells(2, 1)表示A2
Set d(arr(i, 1)) = Cells(i 1, 1).Resize(1, lastCol)
"如果字典中存在arr(i, 1)对应的关键字,则
Else
Set d(arr(i, 1)) = Union(d(arr(i, 1)), Cells(i 1, 1).Resize(1, lastCol))
End If
Next
End With
"将字典中的关键字赋给变量k
k = d.Keys
"将字典中的条目赋给变量t
t = d.Items
" Debug.Print d.Count
"循环，从0到关键字的数量-1
For i = 0 To d.Count - 1
"新建一个工作簿并指定类型
Set wb = Workbooks.Add(xlWBATWorksheet)
"对新工作簿中的第1张表进行操作
With wb.Sheets(1)
"复制rng表示的字段名到新工作簿第1张表A1单元格开始的位置
rng.Copy .Range("A1")
"将关键字对应的条目复制到新工作簿第1张工作表A2单元格起的位置
"条目就是一个区域，可直接cp
t(i).Copy .Range("A2")
End With
"保存新建的工作簿，文件名为各个关键字，扩展名为.xlsx
"加Clean函数是为防止关键字中有非打印字符，造成文件不能保存错误
wb.SaveAs Filename:=ThisWorkbook.Path & "分表" & WorksheetFunction.Clean(k(i)) & ".xlsx"
"关掉新建工作簿
wb.Close
Next i
"释放对象变量
Set rng = Nothing: Set d = Nothing
Application.DisplayAlerts = True
Application.ScreenUpdating = True
MsgBox "拆分完毕！用时" & Timer - tm & "秒", 64, "提示"
End Sub
看图：
附件下载：此文已同步至【知嗒】知识号【Excel精英之家】，相关附件可下载安装【知嗒】app应用，注册一个账号，搜索并关注【Excel精英之家】，加群【Excel精英之家】后方可下载。
