[已解决]按模版进行分表并统计汇总

laye

按单位代码进行分表，并进行数据统计汇总，添入模版相应阴影位置，表名为“单位代码”，每个表生成一个excel文件，文件名为“单位代码+单位汇总表”。

最佳答案

月排行榜 / 总排行榜

dsmch

2014-1-20 14:15

……………………

跳转到最佳答案楼层

laye

各位版主大人，能帮我写这段代码吗，很急用的。

dsmch

1. Sub Macro1()
   
2. Dim arr, d, d1, d2, d3, d4, sht As Worksheet
   
3. Dim i&, j%, k%
   
4. Set d = CreateObject("scripting.dictionary")
   
5. Set d1 = CreateObject("scripting.dictionary")
   
6. Set d2 = CreateObject("scripting.dictionary")
   
7. Set d3 = CreateObject("scripting.dictionary")
   
8. Set d4 = CreateObject("scripting.dictionary")
   
9. Set sht = ThisWorkbook.Sheets("模板")
   
10. Sheets("模板").Activate
    
11. arr = Sheet1.Range("a1").CurrentRegion
    
12. For i = 2 To UBound(arr)
    
13.     d(arr(i, 2)) = arr(i, 3)
    
14.     d1(arr(i, 2)) = d1(arr(i, 2)) + 1
    
15.     d2(arr(i, 2)) = d2(arr(i, 2)) + arr(i, 6)
    
16.     d3(arr(i, 2)) = d3(arr(i, 2)) + arr(i, 7)
    
17.     d4(arr(i, 2)) = d4(arr(i, 2)) + arr(i, 8)
    
18. Next
    
19. Application.ScreenUpdating = False
    
20. Application.DisplayAlerts = False
    
21. Application.SheetsInNewWorkbook = 1
    
22. a = d.keys: b = d.items: b1 = d1.items
    
23. b2 = d2.items: b3 = d3.items: b4 = d4.items
    
24. For i = 0 To d.Count - 1
    
25.     [b5] = a(i)
    
26.     [b6] = b(i)
    
27.     [d12] = b1(i)
    
28.     [d13] = b2(i)
    
29.     [d14] = b3(i)
    
30.     [d15] = b4(i)
    
31.     With Workbooks.Add
    
32.         For j = 1 To 11
    
33.             .Sheets(1).Columns(j).ColumnWidth = sht.Columns(j).ColumnWidth
    
34.         Next
    
35.         For k = 1 To 25
    
36.             .Sheets(1).Rows(k).RowHeight = sht.Rows(k).RowHeight
    
37.         Next
    
38.         sht.[a1:k25].Copy .Sheets(1).[a1]
    
39.         .SaveAs Filename:=ThisWorkbook.Path & "" & a(i) & "单位汇总表.xls"
    
40.     End With
    
41.     Workbooks(a(i) & "单位汇总表.xls").Close 1
    
42. Next
    
43. Application.SheetsInNewWorkbook = 3
    
44. Application.DisplayAlerts = True
    
45. Application.ScreenUpdating = True
    
46. End Sub
    

复制代码

dsmch

……………………

laye

谢谢老师帮助，完全满足需要。

dsmch

1. Sub Macro1()
   
2. Dim arr, brr(1 To 10000, 1 To 5), d, i&, s&, zf$
   
3. Application.ScreenUpdating = False
   
4. Application.DisplayAlerts = False
   
5. Set d = CreateObject("scripting.dictionary")
   
6. arr = Sheet1.Range("a1").CurrentRegion
   
7. For i = 2 To UBound(arr)
   
8.     If Not d.exists(arr(i, 2)) Then
   
9.         s = s + 1
   
10.         d(arr(i, 2)) = s
    
11.         brr(s, 1) = arr(i, 3)
    
12.         brr(s, 2) = 1
    
13.         brr(s, 3) = arr(i, 6)
    
14.         brr(s, 4) = arr(i, 7)
    
15.         brr(s, 5) = arr(i, 8)
    
16.     Else
    
17.         brr(d(arr(i, 2)), 2) = brr(d(arr(i, 2)), 2) + 1
    
18.         brr(d(arr(i, 2)), 3) = brr(d(arr(i, 2)), 3) + arr(i, 6)
    
19.         brr(d(arr(i, 2)), 4) = brr(d(arr(i, 2)), 4) + arr(i, 7)
    
20.         brr(d(arr(i, 2)), 5) = brr(d(arr(i, 2)), 5) + arr(i, 8)
    
21.     End If
    
22. Next
    
23. a = d.keys: b = d.items
    
24. With Sheets("模板")
    
25.     For i = 0 To d.Count - 1
    
26.         .[b5] = a(i)
    
27.         .[b6] = brr(b(i), 1)
    
28.         .[d12] = brr(b(i), 2)
    
29.         .[d13] = brr(b(i), 3)
    
30.         .[d14] = brr(b(i), 4)
    
31.         .[d15] = brr(b(i), 5)
    
32.         zf = a(i) & "单位汇总表.xls"
    
33.         .Copy
    
34.         ActiveWorkbook.SaveAs Filename:=ThisWorkbook.Path & "" & zf
    
35.         Workbooks(zf).Close 1
    
36.     Next
    
37. End With
    
38. Application.DisplayAlerts = True
    
39. Application.ScreenUpdating = True
    
40. End Sub
    

复制代码

简化一下代码，去掉几个字典，直接复制工作表

dsmch

……………………