请教关于分类汇总后另存为文件的VBA

zhongzuo

现在已经做好了分类汇总，需要将结果分给各个机构，所以要粘贴成单独的文件，文件名按机构编号命名。
现有数据：
员工编号        员工姓名        机构编号        员工角色        总工作量
012365        员工甲        1234        普通员工        154
012487        员工乙        1234        普通员工        253
059875        员工丙        1234        普通员工        198
036548        员工丁        1234        普通员工        235
                                    1234 汇总                     840
056887        张三        5678        普通员工        654
096589        李四        5678        普通员工        487
                                 5678 汇总                    1141

想要的结果：
文件1，文件名1234.xls
员工编号        员工姓名        机构编号        员工角色        总工作量
012365        员工甲        1234        普通员工        154
012487        员工乙        1234        普通员工        253
059875        员工丙        1234        普通员工        198
036548        员工丁        1234        普通员工        235
                                1234 汇总         840
文件2，文件名5678.xls
员工编号        员工姓名        机构编号        员工角色        总工作量
056887        张三        5678        普通员工        654
096589        李四        5678        普通员工        487
                                5678 汇总         1141

求高手指教。先谢谢了！！！

zhongzuo

回复 zhongzuo 的帖子

在其他论坛得到了方法。分享给各位，并感谢作者。
Sub Macro1()
    Dim arr, brr(), rng As Range, sh As Worksheet, i&, m&
    Set sh = ActiveSheet
    arr = Range("A1").CurrentRegion
    ReDim brr(1 To UBound(arr))
    Set rng = [a1:e1]
    m = 1
    brr(m) = 1
    For i = 3 To UBound(arr)
        If InStr(arr(i, 3), "汇总") Then
            m = m + 1
            brr(m) = i
        End If
    Next
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    For i = 1 To m - 1
        With Workbooks.Add(xlWBATWorksheet)
            rng.Copy .ActiveSheet.[a1]
            sh.Cells(brr(i) + 1, 1).Resize(brr(i + 1) - brr(i), 5).Copy .ActiveSheet.[a2]
            .SaveAs Filename:=ThisWorkbook.Path & "\" & Split(arr(brr(i + 1), 3), " 汇总")(0) & ".xls"
            .Close
        End With
    Next
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
    MsgBox "ok"
End Sub