姓名所在月份的数量汇总数字填入相应的月份中

陈功

问题：姓名所在月份的数量汇总数字填入相应的月份中。
谢谢大家热心帮助！

LMY123

http://club.excelhome.net/forum. ... &extra=page%3D1

chxw68

1. Sub test()
   
2.   Dim r%, i%
   
3.   Dim arr, brr
   
4.   Dim d As Object
   
5.   Set d = CreateObject("scripting.dictionary")
   
6.   With Worksheets("流水账")
   
7.     r = .Cells(.Rows.Count, 1).End(xlUp).Row
   
8.     arr = .Range("a2:d" & r)
   
9.   End With
   
10.   For i = 1 To UBound(arr)
    
11.     nf = Year(arr(i, 3))
    
12.     yf = Month(arr(i, 3))
    
13.     If Not d.exists(arr(i, 1)) Then
    
14.       Set d(arr(i, 1)) = CreateObject("scripting.dictionary")
    
15.     End If
    
16.     If Not d(arr(i, 1)).exists(arr(i, 2)) Then
    
17.       Set d(arr(i, 1))(arr(i, 2)) = CreateObject("scripting.dictionary")
    
18.     End If
    
19.     If Not d(arr(i, 1))(arr(i, 2)).exists(nf) Then
    
20.       Set d(arr(i, 1))(arr(i, 2))(nf) = CreateObject("scripting.dictionary")
    
21.     End If
    
22.     If Not d(arr(i, 1))(arr(i, 2))(nf).exists(yf) Then
    
23.       ReDim brr(1 To 17)
    
24.       brr(1) = arr(i, 1)
    
25.       brr(2) = arr(i, 2)
    
26.       brr(3) = nf
    
27.       brr(4) = yf
    
28.     Else
    
29.       brr = d(arr(i, 1))(arr(i, 2))(nf)(yf)
    
30.     End If
    
31.     brr(5) = brr(5) + arr(i, 4)
    
32.     brr(yf + 5) = brr(yf + 5) + arr(i, 4)
    
33.     d(arr(i, 1))(arr(i, 2))(nf)(yf) = brr
    
34.   Next
    
35.   With Worksheets("统计")
    
36.     .UsedRange.Offset(1, 0).ClearContents
    
37.     m = 1
    
38.     For Each aa In d.keys
    
39.       For Each bb In d(aa).keys
    
40.         For Each cc In d(aa)(bb).keys
    
41.           For Each dd In d(aa)(bb)(cc).keys
    
42.             brr = d(aa)(bb)(cc)(dd)
    
43.             m = m + 1
    
44.             .Cells(m, 1).Resize(1, UBound(brr)) = brr
    
45.           Next
    
46.         Next
    
47.       Next
    
48.     Next
    
49.     r = .Cells(.Rows.Count, 1).End(xlUp).Row
    
50.     .Range("a1").Resize(r, UBound(brr)).Borders.LineStyle = xlContinuous
    
51.   End With
    
52. End Sub
    

复制代码

chxw68

重新写了一段供参考。

陈功

chxw68 发表于 2018-9-17 11:21
重新写了一段供参考。

非常感谢！