工作中，常常会根据工作表的某一内容来拆分工作博并按照指定的命名新建工作簿，且放入指定的路径文件夹下面。今天就拿昨天的例子，来分享一下如何通过几行代码，快速的拆分工作簿

源数据：

目标工作簿及内容：

问题描述：

1：工资表的原始表格里已经做好了各同事的工资表格；

2：要把每一个同事的工作条提取出来放入新的工作簿里面；

3：工作薄放入指定的文件夹下面；

4：工作薄按照姓名来命名；

解决的思路详解：

继承昨天文章的大致思路

1：把表头作为一个单元格区域并赋值；

2：用for循环遍历工资表区域，提取姓名；

3：用姓名来创建新的工作表；

4：把表头及工作表的内容放入新建的工作簿；

5：关闭并保存工作簿；

代码运行的结果如下：

代码如下:

 Sub 生成工资条() Sub 拆分工作簿() Application.DisplayAlerts = False Application.ScreenUpdating = False Dim sht As Worksheet, arr, i, j Dim rng As Range, Path1 As String Dim name As String '获取当前工作簿的路径 Path1 = ThisWorkbook.Path & "" '设定数据工作表 Set sht = Worksheets("工资表原始表格") '设定标题栏 Set rng = sht.Range("a2:t3") '设定数据源的区域 arr = sht.Range("a1").CurrentRegion '最后一行有合计，所以需要减1 n = UBound(arr, 1) - 1 For i = n To 4 Step -1 'name新建工作簿的名称 name = arr(i, 3) Workbooks.Add.SaveAs Path1 & name & ".xlsx" '复制表头的区域 rng.Copy ActiveSheet.Range("a1") For j = 1 To UBound(arr, 2) Cells(3, j) = arr(i, j) Next '保存并关闭工作簿 Workbooks(name & ".xlsx").Close savechanges:=True Next Application.ScreenUpdating = True Application.DisplayAlerts = TrueEnd Sub End Sub

代码解析

1：2行 关闭Excel自带的对话框；

2：5~7行 DIM定义变量；

3：9行 获取当前工作簿的路径(可以修改成需要的路径)；

4：11行 设定源数据的工作表(可以修改成需要的工作表名称)

5：13行 设置指定的表头区域(可以修改成需要的表头区域)；

6：15行 获取工资表的全部内容；

7：17行 获取最后一行有效数据的行号

8：18~29行 开始遍历工资表区域的内容

9：20行 提取作为新工作簿的名称

10：21行 新建一个工作簿；

11：23行 在新的工作表复制表头；

12：25行 遍历工资表区域的内容，赋值给新的工作表

13：18行 关闭指定工作簿并保存

本例思考：

1：本例作为拆分工作博的典型案例，只需要通过几处的代码，即可扩大代码的使用范围。

小结：

解决本问题，需要用的知识点：

1：工作簿的新建及闭关

延伸阅读：

《Excel VBA 一键工资表制作工资条》

VBA中新建、打开、保存、关闭工作簿！

Excel VBA 拆分工作薄-数组方法

Excel VBA 按工作表名称拆分工作簿

点击关注可以更方便的查看Excel VBA的案例文章

私信 视频 可以获取54集VBA入门视频

私信 VBA或 vba 可以获取文章中含VBA代码的Excle文件