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

不知道为什么

18600349766 发表于 2018-6-27 10:42
感谢，感谢，学到了很多！想请教您，是否可以不分这么细呢，每个以组别命名的文件夹里，只显示员工的总表 ...

员工的明细 不是你要求的么？否则可以少写很多代码啊

你可以把拆分员工明细的那部分删除掉，修改下就可以达到效果

18600349766

不知道为什么 发表于 2018-6-27 10:51
员工的明细 不是你要求的么？否则可以少写很多代码啊

你可以把拆分员工明细的那部分删除掉，修改下就 ...

明白了！谢谢~

liulang0808

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

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.         dn(arr(j, 2)) = ""
    
15.     Next j
    
16.     For j = 0 To dn.Count - 1
    
17.         sfolder = ThisWorkbook.Path & "" & dn.keys()(j)
    
18.         If Not fso.FolderExists(sfolder) Then
    
19.             fso.CreateFolder sfolder
    
20.         End If
    
21.     Next j
    
22.     Sheets.Add after:=Sheets(2)
    
23.     For j = 0 To d.Count - 1
    
24.         With ThisWorkbook.Sheets(3)
    
25.             .UsedRange.Clear
    
26.             .Name = d.keys()(j)
    
27.             d.items()(j).Copy .[a1]
    
28.             r = .UsedRange.Rows.Count + 1
    
29.             .Cells(r, 1) = "合计"
    
30.             .Cells(r, 4) = WorksheetFunction.Sum(.Cells(2, 4).Resize(r))
    
31.             nm = .Cells(2, 2)
    
32.             .Copy
    
33.             With ActiveWorkbook
    
34.                 .SaveAs ThisWorkbook.Path & "" & nm & "" & d.keys()(j) & ".xlsx"
    
35.                 .Close False
    
36.             End With
    
37.         End With
    
38.     Next j
    
39.    
    
40.     ThisWorkbook.Activate
    
41.     Sheets(3).Delete
    
42.     Sheets(1).Select
    
43.     Application.DisplayAlerts = True
    
44.     Application.ScreenUpdating = True
    
45. End Sub

复制代码

liulang0808

附件内容供参考。。。

18600349766

liulang0808 发表于 2018-6-27 12:17
附件内容供参考。。。

谢谢~还想再请教您一下，表格可以根据两个sheet也拆成相应的两个sheet页吗，sheet2的内容是拆分而来，并不是算出来的。根据自己研究了一天没弄明白T T，比如员工A的表格里有两个sheet，如图这样，感谢感谢~

liulang0808

18600349766 发表于 2018-6-27 21:40
谢谢~还想再请教您一下，表格可以根据两个sheet也拆成相应的两个sheet页吗，sheet2的内容是拆分而来，并 ...

这个可以实现，跟之前的有些雷同。

18600349766

liulang0808 发表于 2018-6-27 21:43
这个可以实现，跟之前的有些雷同。

可以给一些提示嘛，新手不太懂啊(灬ꈍ ꈍ灬)

18600349766

liulang0808 发表于 2018-6-27 21:43
这个可以实现，跟之前的有些雷同。

可以给点提示嘛，第一次学不太懂啊T T

liulang0808

18600349766 发表于 2018-6-27 21:56
可以给点提示嘛，第一次学不太懂啊T T

在生成新工作薄，增加一张表，然后添加即可

liulang0808

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

复制代码