如何拆分并根据规则保存文件

18600349766

求教各位大神：例如文档sheet1为1月工资明细表（包含员工A、B、C等等），sheet2为工资汇总表。怎样按姓名拆分成不同员工的工资明细，工资汇总，整合到一个文档的多个sheet页，并根据第二列的组长，将相应员工的表格保存到以小组长命名的文件夹里，谢谢！祝生活愉快！

不知道为什么

如图所示，是楼主需要的效果？

如果可以，请评分哈！

liulang0808

1. Sub 按钮1_Click()
   
2.     Set fso = CreateObject("scripting.filesystemobject")
   
3.     Set d = CreateObject("scripting.dictionary")
   
4.     Set dn = CreateObject("scripting.dictionary")
   
5.     arr = Sheets("工资明细").[a1].CurrentRegion
   
6.     Application.ScreenUpdating = False
   
7.     Application.DisplayAlerts = False
   
8.     For j = 2 To UBound(arr)
   
9.         If Not d.exists(arr(j, 1)) Then
   
10.             Set d(arr(j, 1)) = Union([a1:d1], Cells(j, 1).Resize(1, 4))
    
11.         Else
    
12.             Set d(arr(j, 1)) = Union(d(arr(j, 1)), Cells(j, 1).Resize(1, 4))
    
13.         End If
    
14.         If Not dn.exists(arr(j, 2)) Then
    
15.             dn(arr(j, 2)) = arr(j, 1)
    
16.         Else
    
17.             If InStr(dn(arr(j, 2)), arr(j, 1)) = 0 Then
    
18.                 dn(arr(j, 2)) = dn(arr(j, 2)) & "," & arr(j, 1)
    
19.             End If
    
20.         End If
    
21.     Next j
    
22.     For j = 0 To d.Count - 1
    
23.         Sheets.Add after:=Sheets(2)
    
24.         With Sheets(3)
    
25.             .Name = d.keys()(j)
    
26.             d.items()(j).Copy .[a1]
    
27.             r = .UsedRange.Rows.Count + 1
    
28.             .Cells(r, 1) = "合计"
    
29.             .Cells(r, 4) = WorksheetFunction.Sum(.Cells(2, 4).Resize(r))
    
30.         End With
    
31.     Next j
    
32.     For j = 0 To dn.Count - 1
    
33.         ThisWorkbook.Activate
    
34.         sfolder = ThisWorkbook.Path & "" & dn.keys()(j)
    
35.         If Not fso.FolderExists(sfolder) Then
    
36.             fso.CreateFolder sfolder
    
37.         End If
    
38.         If InStr(dn.items()(j), ",") > 0 Then
    
39.             brr = Split(dn.items()(j), ",")
    
40.             Sheets(Split(dn.items()(j), ",")).Copy
    
41.         Else
    
42.             Sheets(dn.items()(j)).Copy
    
43.         End If
    
44.         With ActiveWorkbook
    
45.             .SaveAs sfolder & "" & dn.keys()(j) & ".xlsx"
    
46.             .Close False
    
47.         End With
    
48.     Next j
    
49.     ThisWorkbook.Activate
    
50.     For j = Sheets.Count To 3 Step -1
    
51.         Sheets(j).Delete
    
52.     Next j
    
53.     Application.DisplayAlerts = True
    
54.     Application.ScreenUpdating = True
    
55. End Sub
    

复制代码

liulang0808

附件内容供参考
每个组长创建一个文件夹，并以组长命名一张表

18600349766

liulang0808 发表于 2018-6-27 08:04
附件内容供参考
每个组长创建一个文件夹，并以组长命名一张表

感谢大神！麻烦再您帮忙看一下，是否可以直接在组别文件夹里，继续拆分成以员工命名的文件，如打开李四文件夹，会显示E、F的文件，谢谢了！

LMY123

字典拆分成工作薄

不知道为什么

18600349766 发表于 2018-6-27 09:30
感谢大神！麻烦再您帮忙看一下，是否可以直接在组别文件夹里，继续拆分成以员工命名的文件，如打开李四文 ...

夜里做的，给忘了发代码了。补上

不知道为什么

18600349766 发表于 2018-6-27 09:30
感谢大神！麻烦再您帮忙看一下，是否可以直接在组别文件夹里，继续拆分成以员工命名的文件，如打开李四文 ...

附件送上 供测试

记得评分哈

18600349766

不知道为什么 发表于 2018-6-27 10:19
附件送上 供测试

记得评分哈

感谢，感谢，学到了很多！想请教您，是否可以不分这么细呢，每个以组别命名的文件夹里，只显示员工的总表就可以，如下图所示，麻烦您再帮忙看下(๑′ᴗ‵๑)