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

　　前言：工作簿数据的拆分，有各种各样的需求，本示例介绍其中的一种需求实现，后续将会陆续补充相关内容。
　　借鉴此示例，你可以将信贷台账等按机构拆分开来，总之，举一返三，这方面的应用不时都会用到。
　　用循环嵌套速度慢，用数组字典的方式处理速度会快很多。经测试，5万笔数据，132列，用时23秒完成拆分。
　　数据源：
　　结果：
　　Code：
　　function：将当前工作表按第2列中的关键字拆分为各个不同的工作簿
　　需要在VBE工具引用中添加windowsscriptHostObjectModel
　　SubSplitSht（）
　　变量声明
　　Dimtm，FsoAsFileSystemObject，sfolder，wbAsWorkbook，arr
　　DimrngAsRange，lastRowamp；amp；，lastCol，dAsObject，k，t，shAsWorksheet，iamp；amp；
　　tmTimer计时开始
　　创建文件系统对象
　　SetFsoCreateObject（Scripting。FileSystemObject）
　　在当前文件夹中创建一个子目录用于存放拆分好的工作簿文件
　　sfolderThisWorkbook。Pathamp；amp；分表
　　若子目录不存在，创建之
　　IfFso。FolderExists（sfolder）FalseThenFso。CreateFoldersfolder
　　关闭屏幕更新，防止闪屏，加快处理速度
　　Application。ScreenUpdatingFalse
　　关闭使用工作簿的SaveAs方法覆盖现有文件，覆盖警告默认为No
　　当DisplayAlerts属性设置等于False时，Excel选择Yes响应。
　　Application。DisplayAlertsFalse
　　对Sheet1表进行操作，可据实修改
　　WithSheets（Sheet1）
　　将Sheet1表单元格区域A1：C1（字段名）赋给对象变量rng
　　Setrng。Range（A1：EB1）
　　取B列最后一个有数据的单元格所在行行号赋给变量lastRow
　　lastRow。Range（Bamp；amp；Rows。Count）。End（xlUp）。Row
　　根据不同的Office版本（2007为12。0），取第一行最后一个有数据的单元格所在列列号赋给变量lastCol
　　IfApplication。Versionamp；gt；12。0Then
　　lastCol。Range（XFD1）。End（xlToLeft）。Column
　　Else
　　lastCol。Range（IV1）。End（xlToLeft）。Column
　　EndIf
　　将关键字所在列中B1到B列最后一个有数据的单元格组成的区域赋给数组arr
　　实际运用中关键字所在列据实修改
　　arr。Range（B2：Bamp；amp；lastRow）
　　创建字典对象
　　SetdCreateObject（scripting。dictionary）
　　Debug。PrintUBound（arr）
　　循环，从1到数组arr第一维最大下标
　　Fori1ToUBound（arr）
　　如果字典中不存在arr（i，1）对应的关键字，则
　　IfNotd。Exists（arr（i，1））Then
　　添加关键字及条目
　　首次循环时，条目为单元格A2向右扩展1行3列的单元格区域即A2：D2
　　i要加1是因为首次代入的变量为1，加1后变为2，Cells（2，1）表示A2
　　Setd（arr（i，1））Cells（i1，1）。Resize（1，lastCol）
　　如果字典中存在arr（i，1）对应的关键字，则
　　Else
　　用Union方法将原有的条目和新添加的条目组合为一个区域
　　字典的关键字不可以修改，但条目是可以不断修改的
　　Setd（arr（i，1））Union（d（arr（i，1）），Cells（i1，1）。Resize（1，lastCol））
　　EndIf
　　Next
　　EndWith
　　将字典中的关键字赋给变量k
　　kd。Keys
　　将字典中的条目赋给变量t
　　td。Items
　　Debug。Printd。Count
　　循环，从0到关键字的数量1
　　Fori0Tod。Count1
　　新建一个工作簿并指定类型
　　SetwbWorkbooks。Add（xlWBATWorksheet）
　　对新工作簿中的第1张表进行操作
　　Withwb。Sheets（1）
　　复制rng表示的字段名到新工作簿第1张表A1单元格开始的位置
　　rng。Copy。Range（A1）
　　将关键字对应的条目复制到新工作簿第1张工作表A2单元格起的位置
　　条目就是一个区域，可直接cp
　　t（i）。Copy。Range（A2）
　　EndWith
　　保存新建的工作簿，文件名为各个关键字，扩展名为。xlsx
　　加Clean函数是为防止关键字中有非打印字符，造成文件不能保存错误
　　wb。SaveAsFilename：ThisWorkbook。Pathamp；amp；分表amp；amp；WorksheetFunction。Clean（k（i））amp；amp；。xlsx
　　关掉新建工作簿
　　wb。Close
　　Nexti
　　释放对象变量
　　SetrngNothing：SetdNothing
　　Application。DisplayAlertsTrue
　　Application。ScreenUpdatingTrue
　　MsgBox拆分完毕！用时amp；amp；Timertmamp；amp；秒，64，提示
　　EndSub
　　看图：
　　附件下载：此文已同步至【知嗒】知识号【Excel精英之家】，相关附件可下载安装【知嗒】app应用，注册一个账号，搜索并关注【Excel精英之家】，加群【Excel精英之家】后方可下载。