跪求代码

全党

字典嵌套，练下手。。。。。。。

1. Sub shishi()
   
2. Dim arr, brr(), d, rq
   
3. Set d = CreateObject("Scripting.Dictionary")
   
4. Set rq = CreateObject("Scripting.Dictionary")
   
5. r = Sheets(1).Cells(Rows.Count, 1).End(xlUp).Row
   
6. c = Sheets(1).Cells(6, Columns.Count).End(xlToLeft).Column
   
7. arr = Sheets(1).Range("a6").Resize(r, c)
   
8. For i = 2 To UBound(arr)
   
9.        If arr(i, 1) <> "" Then
   
10.             arr(i, 1) = Format(arr(i, 1), "yyyy-mm")
    
11.             rq(arr(i, 1)) = ""
    
12.             Key = arr(i, 2) & "," & arr(i, 3) & "," & arr(i, 4)
    
13.         End If
    
14.             If Not d.exists(Key) Then
    
15.                Set d(Key) = CreateObject("Scripting.Dictionary")
    
16.                d(Key)(arr(i, 1)) = arr(i, 5)
    
17.            Else
    
18.                d(Key)(arr(i, 1)) = d(Key)(arr(i, 1)) + arr(i, 5)
    
19.             End If
    
20.      Next
    
21. ReDim brr(1 To d.Count, 1 To rq.Count + 3)
    
22. Sheets(2).UsedRange.ClearContents
    
23. Sheets(2).[d4].Resize(1, rq.Count) = rq.keys
    
24. 
    
25. For Each Key In d.keys
    
26. n = n + 1
    
27.     For j = 4 To UBound(brr, 2)
    
28.     tt = Split(Key, ",")
    
29.     brr(n, 1) = tt(0): brr(n, 2) = tt(1): brr(n, 3) = tt(2)
    
30.     k = Format(Sheets(2).Cells(4, j), "yyyy-mm"): brr(n, j) = d(Key)(k)
    
31.     Next
    
32. Next
    
33. Sheets(2).[a5].Resize(d.Count, UBound(brr, 2)) = brr
    
34. End Sub

复制代码