【对个分表重量金额分别进行合计】

无涯wbb

大家好！

公司要求对各个区域材料对应的重量 金额分别进行合计
数量比较大，手动时间比较长，而且后期还在不断增加，希望能够得到论坛朋友的帮助 先谢谢了

无涯wbb

看了蓝桥老师的字典 12项的事例很像 但是不会操作
http://club.excelhome.net/thread-868892-1-1.html

莫名v微笑

1. Sub test()
   
2. Dim d, d2, arr, brr
   
3. Application.ScreenUpdating = False
   
4. Set d = CreateObject("scripting.dictionary")
   
5. Set d2 = CreateObject("scripting.dictionary")
   
6. With Sheets("重量金额合计")
   
7. .Columns(1).Clear
   
8. For i = 3 To Sheets.Count
   
9. arr = Sheets(i).UsedRange
   
10. For u = 2 To UBound(arr)
    
11. If arr(u, 15) <> "" Then
    
12. d(arr(u, 15)) = ""
    
13. d2(Sheets(i).Name & arr(u, 15) & "合计重量") = d2(Sheets(i).Name & arr(u, 15) & "合计重量") + arr(u, 25)
    
14. d2(Sheets(i).Name & arr(u, 15) & "含税金额") = d2(Sheets(i).Name & arr(u, 15) & "含税金额") + arr(u, 29)
    
15. End If
    
16. Next
    
17. Next
    
18. .Range("a2") = "材料"
    
19. .Range("a3").Resize(d.Count) = WorksheetFunction.Transpose(d.Keys)
    
20. brr = .UsedRange
    
21. For i = 3 To UBound(brr)
    
22. For u = 3 To UBound(brr, 2) Step 3
    
23. For o = 1 To 2
    
24. If o = 1 Then
    
25. If d2.exists(brr(1, u) & brr(i, 1) & brr(2, u)) Then brr(i, u) = d2(brr(1, u) & brr(i, 1) & brr(2, u))
    
26. Else:
    
27. If d2.exists(brr(1, u) & brr(i, 1) & brr(2, u + 1)) Then brr(i, u + 1) = d2(brr(1, u) & brr(i, 1) & brr(2, u + 1))
    
28. End If
    
29. Next
    
30. Next
    
31. Next
    
32. .Range("a1").Resize(UBound(brr), UBound(brr, 2)) = brr
    
33. End With
    
34. Set d = Nothing
    
35. Set d2 = Nothing
    
36. Set arr = Nothing
    
37. Set brr = Nothing
    
38. Application.ScreenUpdating = True
    
39. End Sub
    

复制代码

我稍微更改了一下你的表格。

iwangyi

Set d1 = CreateObject("scripting.dictionary")
For Each sh In Sheets
If sh.Name <> "重量金额合计" And sh.Name <> "重量金额分析表" Then
arr = sh.UsedRange
  For i = 2 To UBound(arr)

   d(arr(i, 15) & sh.Name) = d(arr(i, 15) & sh.Name) + arr(i, 25)
   d1(arr(i, 15) & sh.Name) = d1(arr(i, 15) & sh.Name) + arr(i, 29)
  Next
  End If
Next
n = [b65536].End(3).Row
For y = 3 To 27 Step 3
For x = 3 To n
Cells(x, y) = d(Cells(x, 2) & Cells(1, y))
Cells(x, y + 1) = d1(Cells(x, 2) & Cells(1, y))
Next
Next
End Sub

iwangyi

代码审核 附件先上

excelvlookup

写个嵌套数组，这样的例子好象不多
Sub aa()
a = ThisWorkbook.Sheets.Count
ReDim ar(1 To a - 2, 1 To 2)
Set d = CreateObject("scripting.dictionary")
For Each sh In Sheets
    i = i + 1
    If sh.Name Like "*重量金额*" = 0 Then
        n = n + 1
        ar(n, 1) = sh.Name
        ar(n, 2) = sh.Range("o2:ac" & sh.Cells(Rows.Count, 15).End(3).Row)
        If b < UBound(ar(n, 2)) Then b = UBound(ar(n, 2))
    End If
Next
ReDim br(1 To b, 1 To n * 3 + 1)
s = 2: s1 = 1
For i = 1 To n
    s1 = s1 + 3
    d(ar(i, 1)) = s1
    br(1, s1 - 2) = ar(i, 1): br(2, s1 - 2) = "合计重量"
    br(2, s1 - 1) = "合计金额": br(2, s1) = "**更新日期"
    For j = 1 To UBound(ar(i, 2))
        ky = ar(i, 2)(j, 1)
        r = d(ky)
        If r = "" Then
            s = s + 1
            d(ky) = s
            r = s
        End If
        br(r, 1) = ar(i, 2)(j, 1)
        br(r, s1 - 2) = br(r, s1 - 2) + ar(i, 2)(j, 11)
        br(r, s1 - 1) = br(r, s1 - 1) + ar(i, 2)(j, 15)
        'br(r, s1 - 1) = "写上更新日期"
    Next
Next
Sheets("重量金额合计").[b30].Resize(s, s1) = br
End Sub

无涯wbb

莫名v微笑 发表于 2018-8-21 17:54
我稍微更改了一下你的表格。

谢谢前辈指导 谢谢

无涯wbb

iwangyi 发表于 2018-8-21 20:26
代码审核 附件先上

你好   附近忘记上传那 您

无涯wbb

excelvlookup 发表于 2018-8-21 20:33
写个嵌套数组，这样的例子好象不多
Sub aa()
a = ThisWorkbook.Sheets.Count

多谢老师指导
但是,怎么会自动生成表头啊,怎么把那个表头去掉呀 嘿嘿

iwangyi

无涯wbb 发表于 2018-8-22 08:46
你好   附近忘记上传那 您

系统卡，附件补上