关于嵌套字典提取数据

启航2014

最近初学字典，进行练手字，做了一个用嵌套字典来实现数据透视表的功能。但我的代码在提取数据代码显得特别啰嗦（绿色区域）。不知道可以哪位大神可以指点指点，有没有其他的实现方法。拜托，感谢！

A-D列为数据源，H-L为输出区域。我的代码如下：
Sub d()
Dim arr, arr2()
Dim d As Object, d1 As Object
arr = Sheets("Sheet1").Range("A2:D37")
Set d1 = CreateObject("scripting.dictionary")
For i = 1 To UBound(arr, 1)
t = arr(i, 1)
m = arr(i, 2)
n = arr(i, 3)
If Not d1.exists(t) Then Set d1(t) = CreateObject("scripting.dictionary")
    If Not d1(t).exists(m) Then Set d1(t)(m) = CreateObject("scripting.dictionary")
        If Not d1(t)(m).exists(n) Then
        d1(t)(m)(n) = Array(arr(i, 4), 1)
        Else
        d1(t)(m)(n) = Array(d1(t)(m)(n)(0) + arr(i, 4), d1(t)(m)(n)(1) + 1)
          End If
Next i
Range("H:L").CurrentRegion.Offset(1) = ""
j = 2
For Each key1 In d1
    For Each key2 In d1(key1)
        For Each key3 In d1(key1)(key2)
            If key3 <> "" Then      
            Cells(j, 8).Resize(1, 3) = Array(key1, key2, key3)
            Cells(j, 11).Resize(1, 2) = d1(key1)(key2)(key3)      
            j = j + 1
            End If
Next  
    Next
        Next
End Sub

山菊花

针对问题，不建议使用嵌套，下面代码供参考。

1. Sub Test()
   
2.     Dim nRow%, Arr(), Brr(), cTxt$
   
3.     Dim d As Object, m%, n%
   
4.     With Sheets("Sheet1")
   
5.         nRow = .Range("a1").End(xlDown).Row
   
6.         Arr = .Range("A1:d" & nRow).Value
   
7.         Set d = CreateObject("scripting.dictionary")
   
8.         ReDim Brr(1 To nRow, 1 To 5)
   
9.         For i = 2 To nRow
   
10.             cTxt = Arr(i, 1) & "," & Arr(i, 2) & "," & Arr(i, 3)
    
11.             If Not d.exists(cTxt) Then
    
12.                 m = m + 1
    
13.                 d(cTxt) = m
    
14.                 Brr(m, 1) = Arr(i, 1)
    
15.                 Brr(m, 2) = Arr(i, 2)
    
16.                 Brr(m, 3) = Arr(i, 3)
    
17.                 Brr(m, 4) = Arr(i, 4)
    
18.                 Brr(m, 5) = 1
    
19.             Else
    
20.                 n = d(cTxt)
    
21.                 Brr(n, 4) = Brr(n, 4) + Arr(i, 4)
    
22.                 Brr(n, 5) = Brr(n, 5) + 1
    
23.             End If
    
24.         Next
    
25.         nRow = .Range("h1048576").End(xlUp).Row
    
26.         If nRow > 1 Then
    
27.             .Range("h2:l" & nRow).ClearContents
    
28.         End If
    
29.         .Range("h2:l" & m + 1).Value = Brr
    
30.     End With
    
31. End Sub

复制代码

启航2014

感谢总版主的回复，学习下思路！