Excel 用VBa数组和字典求四条件同一时，所对应的1至12月，各自相对应的汇总数字

Sub zzz()
Sheets("要答案的工作表").Activate
Dim d, arr, brr, i, j, x, y, s$
Set d = CreateObject("scripting.dictionary")
arr = Sheets("原始数据").[a1].CurrentRegion.Value
x = UBound(arr, 2): y = UBound(arr)
brr = [a1].CurrentRegion.Value
For i = 2 To y
  For j = 6 To x
    s = arr(i, 2) & arr(i, 3) & arr(i, 4) & arr(i, 5) & arr(1, j)
    d(s) = d(s) + arr(i, j)
  Next
Next
For i = 2 To UBound(brr)
  For j = 6 To x
    s = brr(i, 2) & brr(i, 3) & brr(i, 4) & brr(i, 5) & brr(1, j)
    brr(i, j) = d(s)
  Next
Next
[a1].Resize(UBound(brr), x) = brr
End Sub

*****************************

1. Sub yyy()
2. Sheets("要答案的工作表").Activate
3. Dim d, arr, brr, i, j, m, n, x, y
4. Set d = CreateObject("scripting.dictionary")
5. arr = Sheets("原始数据").[a1].CurrentRegion.Value
6. x = UBound(arr, 2): y = UBound(arr)
7. ReDim brr(1 To y, 1 To x)
8. For i = 2 To y
9.   s = arr(i, 2) & arr(i, 3) & arr(i, 4) & arr(i, 5)
10.   d(s) = Array(Empty, arr(i, 2), arr(i, 3), arr(i, 4), arr(i, 5))
11. Next
12. [a2].Resize(d.Count, 5) = Application.Rept(d.items, 1)
13. d.RemoveAll
14. brr = [a1].CurrentRegion.Value
15. For i = 2 To y
16.   For j = 6 To x
17.     s = arr(i, 2) & arr(i, 3) & arr(i, 4) & arr(i, 5) & arr(1, j)
18.     d(s) = d(s) + arr(i, j)
19.   Next
20. Next
21. For i = 2 To UBound(brr)
22.   For j = 6 To x
23.     s = brr(i, 2) & brr(i, 3) & brr(i, 4) & brr(i, 5) & brr(1, j)
24.     brr(i, j) = d(s)
25.   Next
26. Next
27. [a1].Resize(UBound(brr), x) = brr
28. End Sub