使用按某列中的关键字拆分为单独的工作簿

　　前言：工作簿数据的拆分，有各种各样的需求，本示例介绍其中的一种需求实现，后续将会陆续补充相关内容。
　　借鉴此示例，你可以将信贷台账等按机构拆分开来，总之，举一返三，这方面的应用不时都会用到。
　　用循环嵌套速度慢，用数组 字典的方式处理速度会快很多。经测试，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
　　＂用Union方法将原有的条目和新添加的条目组合为一个区域
　　＂字典的关键字不可以修改，但条目是可以不断修改的
　　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精英之家】后方可下载。