【前言】
在推进各种人力资源项目过程中，经常需要组织其他同事完成一定业务动作后，将成果输入到预先制定的表格中并反馈。我们称之为项目数据协同。
为了确保数据协同的质量、效率，关键是做好四点：（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 & " 0-年终奖金测算结果.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
② 实际使用中，需要根据拆分的实际情况对上述代码中工作表名称、相关行列位置做相应挑战。
