[已解决]对另一工作簿内所有的工作表进行多条件求和

shixyi37

多个多条件求和（见附件），请求各位VBA高手帮助，麻烦了、辛苦了，谢谢！
请教：多条件求和.zip (6.19 KB, 下载次数: 15)

2015-9-29 18:32 上传

点击文件名下载附件

最佳答案

月排行榜 / 总排行榜

grf1973

2015-9-30 11:19

请看附件。

跳转到最佳答案楼层

Tank008

你这差不多是让人帮你把工作干完了。

grf1973

1. Sub 求和()
   
2.     On Error Resume Next
   
3.     Dim wb As Workbook, sh As Worksheet
   
4.     Set wb = Workbooks.Open(ThisWorkbook.Path & "\多条件求和数据源.xls")
   
5.     Set wb = Workbooks("多条件求和数据源.xls")
   
6.     On Error GoTo 0
   
7.     Set d1 = CreateObject("scripting.dictionary")
   
8.     Set d2 = CreateObject("scripting.dictionary")
   
9.     Set d3 = CreateObject("scripting.dictionary")
   
10.     Set d4 = CreateObject("scripting.dictionary")
    
11.     Set d5 = CreateObject("scripting.dictionary")
    
12.     For Each sh In wb.Worksheets
    
13.         arr = sh.[a1].CurrentRegion
    
14.         For i = 2 To UBound(arr)
    
15.             If arr(i, 2) = "" Then arr(i, 2) = arr(i - 1, 2)    '用上一格内容填齐空格部分（编码、名称、部门）
    
16.             If arr(i, 3) = "" Then arr(i, 3) = arr(i - 1, 3)
    
17.             If arr(i, 7) = "" Then arr(i, 7) = arr(i - 1, 7)
    
18.             je = arr(i, 6)     '金额
    
19.             
    
20.             bm = arr(i, 7): lb = "类别" & arr(i, 4) '部门、类别
    
21.             k1 = bm & lb       '部门+类别
    
22.             d1(k1) = d1(k1) + je
    
23.             If arr(i, 8) = "√" Then d2(k1) = d2(k1) + je
    
24.             
    
25.             mx = arr(i, 5)   '明细
    
26.             k3 = bm & mx
    
27.             d3(k3) = d3(k3) + je
    
28.             If arr(i, 8) = "√" Then d4(k3) = d4(k3) + je
    
29.             
    
30.             k5 = arr(i, 2) & arr(i, 4) '编码+大类
    
31.             d5(k5) = d5(k5) + je
    
32.         Next
    
33.     Next
    
34.     wb.Close False
    
35.     For m = 1 To 5
    
36.         Set sh = ThisWorkbook.Sheets(m)
    
37.         brr = sh.[a1].CurrentRegion
    
38.         For i = 3 To UBound(brr)
    
39.             p = IIf(m = 5, 3, 2)      '第五张表从第三列开始填，其他从第二列开始
    
40.             For j = p To UBound(brr, 2)
    
41.                 k = brr(i, 1) & brr(2, j)
    
42.                 If m = 1 Then brr(i, j) = d1(k)
    
43.                 If m = 2 Then brr(i, j) = d2(k)
    
44.                 If m = 3 Then brr(i, j) = d3(k)
    
45.                 If m = 4 Then brr(i, j) = d4(k)
    
46.                 If m = 5 Then brr(i, j) = d5(k)
    
47.             Next
    
48.         Next
    
49.         sh.[a1].CurrentRegion = brr
    
50.     Next
    
51. End Sub

复制代码

grf1973

请看附件。

shixyi37

grf1973 发表于 2015-9-30 11:19
请看附件。

太感谢太神奇了