如何将一个工作簿的多个工作表拆分（excel工作簿拆分多个工作表）【百科全说】

【前言】

在推进各种人力资源项目过程中，经常需要组织其他同事完成一定业务动作后，将成果输入到预先制定的表格中并反馈。我们称之为项目数据协同。

为了确保数据协同的质量、效率，关键是做好四点：（1）简化：向我们反馈数据表的人，他们需要执行的动作越少越好；（2）指引：表格操作指引要简要、精准，相关培训得到位；（3）数据流管控：不需协同人操作的区域、内容，通过内容保护设置限定其可操作的动作，防止误操作；（4）批量操作工具化：基于VBA自动完成下发表格的拆分、回收表格的汇集。

在具体实施过程中，前两点的个性化较强，往往需要结合实际情况因地制宜地做相应安排。后两点的实施对应五个Excel技能实施。本文是其中第五篇，且相关示例基于Microsoft Excel软件制作。

【业务场景】：

项目协同的另一常见情境是将文件按照某个字段的不同拆分成若干Excel工作簿，并交给项目协作方去完成后续操作。例如，将定稿的公司整体奖金分配测算表按部门拆分并分别交给HBRP，以支持其完成年终奖项目后续事宜。

【需求示例】：

假设有已完成沟通、确认的年奖奖金测算表（“00-年终奖金测算结果”）：

图 1 拆分年终奖金测算结果

待拆分的测算表名称为“部门奖金分配表”。现需要通过VBA根据部门的不同拆分汇总测算结果：

（1）拆分后文件以部门名称进行命名；

（2）拆分后测算表中的计算公式保持不变；

（3）根据规则重新设置拆分后的部门奖金分配表格式。

图 2 待拆分表格示例

【实现步骤】：

Step1：将工作簿“00-年终奖金测算结果”中待拆分内容整体粘贴进拆分模板

本步操作简单，略。

Step2：创建用于存储拆分后各部门奖金分配表的文件夹

图 3 拆分后各部门奖金分配表

Step3：在拆分模板中设置拆分规则

图 4 拆分规则配置

如上图：

（1）B1单元格“主键所在列”，即实施拆分时所依据的字段（示例中为“一级部门”）在待拆分表格中的所在列（示例中为“F列”，参见图1-1-29）；

（2）B2单元格“存储路径”，即拆分后各部门奖金分配表的存储位置，可根据需要配置。

Step4：通过“ALT F11”组合键打开VBA代码编辑器并执行程序

图 5 VBA代码执行窗口

拆分结果如下图所示：

图 6 代码执行效果示例

【说明】：

① 拆分工具详见本书相关附件。代码如下：

Sub 拆分表格()

Dim w, j, k, m, n As Integer

Dim rng As Range

Dim strkey, strrng As String

Dim sourcepath, savepath, filename As String

Dim wb As Workbook

'
----------------------------------------------------------------------------------------------提取主键清单

m = 0

n = 0

strkey = ThisWorkbook.Sheets("拆分规则").Range("B1")

w = ThisWorkbook.Sheets("部门奖金分配表").Range(strkey & 65536).End(xlUp).Row

strrng = ThisWorkbook.Sheets("部门奖金分配表").Range("F10") & "F" & w

ThisWorkbook.Sheets("拆分规则").Range("A6:A" & ThisWorkbook.Sheets("拆分规则").Range("A65536").End(xlUp).Row).Clear

Set rng = ThisWorkbook.Sheets("部门奖金分配表").Range("F9:" & "F" & w)

rng.AdvancedFilter Action:=xlFilterCopy, Unique:=True, copytorange:=ThisWorkbook.Sheets("拆分规则").Range("A4")

Set rng = Nothing

'
------------------------------------------------------------------------------------------------拆分

j = ThisWorkbook.Sheets("拆分规则").Range("A65536").End(xlUp).Row

sourcepath = ThisWorkbook.Path & "\00-年终奖金测算结果.xlsx"

Application.DisplayAlerts = False

For i = 6 To j

filename = ThisWorkbook.Sheets("拆分规则").Cells(i, 1)

savepath = ThisWorkbook.Sheets("拆分规则").Range("B2") & "\" & filename & ".xlsx"

FileCopy sourcepath, savepath

Workbooks.Open (savepath)

m = Workbooks(filename).Sheets("部门奖金分配表").Range("B65536").End(xlUp).Row

For k = m To 10 Step -1

If Workbooks(filename).Sheets("部门奖金分配表").Cells(k, 6).Value <> filename Then

Workbooks(filename).Sheets("部门奖金分配表").Cells(k, 6).EntireRow.Delete

End If

Next k

n = Workbooks(filename).Sheets("部门奖金分配表").Range("B65536").End(xlUp).Row

With Workbooks(filename).Sheets("部门奖金分配表").Range("B8:AC" & n)

.BorderAround xlContinuous, xlMedium

End With

Workbooks(filename).Save

Workbooks(filename).Close

Next i

Application.DisplayAlerts = True

End Sub

②　实际使用中，需要根据拆分的实际情况对上述代码中工作表名称、相关行列位置做相应挑战。

如何将一个工作簿的多个工作表拆分（excel工作簿拆分多个工作表）

相关推荐