用字典嵌套统计

dsmch

1. Sub Macro1()
   
2. Dim arr, brr, crr, d As Object, i&, j&
   
3. Set d = CreateObject("scripting.dictionary")
   
4. arr = Range("a1").CurrentRegion '原始数据
   
5. brr = Range("a15").CurrentRegion '目标数据
   
6. ReDim crr(1 To UBound(brr) - 1, 1 To UBound(brr, 2) - 1)
   
7. For i = 2 To UBound(arr)
   
8.     Set d(arr(i, 1)) = CreateObject("scripting.dictionary") '设置字典嵌套
   
9. Next
   
10. For i = 2 To UBound(arr)
    
11.     For j = 2 To UBound(arr, 2)
    
12.         d(arr(i, 1))(arr(1, j)) = d(arr(i, 1))(arr(1, j)) + arr(i, j)
    
13.     Next
    
14. Next
    
15. For i = 2 To UBound(brr)
    
16.     For j = 2 To UBound(brr, 2)
    
17.         crr(i - 1, j - 1) = d(brr(i, 1))(brr(1, j))
    
18.     Next
    
19. Next
    
20. Range("b16").Resize(UBound(crr), UBound(crr, 2)) = crr
    
21. End Sub
    

复制代码

通常字典是一对一对应，在一对多的情况下，先用符号连接，然后用split分割，字典嵌套能很好地解决这类问题，详细见附件

longming3

好例子，学习老师的方法

lzyamo3057

这个例子，好象不要用上split分割吧？

lzyamo3057

1. Sub test()
   
2.     Dim arr, brr, crr, d, i
   
3.     Set d = CreateObject("scripting.dictionary")
   
4.     arr = Range("a1").CurrentRegion    '原始数据
   
5.     brr = Range("a15").CurrentRegion    '目标数据
   
6.     ReDim crr(1 To UBound(brr) - 1, 1 To UBound(brr, 2) - 1)
   
7.     For i = 2 To UBound(arr)
   
8.         For j = 2 To UBound(arr, 2)
   
9.             s = arr(i, 1) & arr(1, j)
   
10.             d(s) = d(s) + arr(i, j)
    
11.         Next
    
12.     Next
    
13.     For i = 2 To UBound(brr)
    
14.         For j = 2 To UBound(brr, 2)
    
15.             s = brr(i, 1) & brr(1, j)
    
16.             If d.exists(s) Then
    
17.                 crr(i - 1, j - 1) = d(s)
    
18.             End If
    
19.         Next
    
20.     Next
    
21.     Range("b16").Resize(UBound(crr), UBound(crr, 2)) = crr
    
22.     Set d = Nothing
    
23. End Sub

复制代码

dsmch

lzyamo3057 发表于 2013-5-2 21:28
这个例子，好象不要用上split分割吧？

是的，这个用不上，一般情况下要用5个字典对象。
楼上一个字典解决了{:soso_e179:}

longming3

1. Sub Macro2()
   
2.     Dim arr, brr, crr, d As Object, i&, j&
   
3.     Set d = CreateObject("scripting.dictionary")
   
4.     arr = Range("a1").CurrentRegion '原始数据
   
5.     brr = Range("a15").CurrentRegion '目标数据
   
6.     ReDim crr(1 To UBound(brr) - 1, 1 To UBound(brr, 2) - 1)
   
7. 
   
8.     For i = 2 To UBound(arr)
   
9.         For j = 2 To UBound(arr, 2)
   
10.             d(arr(i, 1) & "#" & arr(1, j)) = d(arr(i, 1) & "#" & arr(1, j)) + arr(i, j)
    
11.         Next
    
12.     Next
    
13. 
    
14.     For i = 2 To UBound(brr)
    
15.         For j = 2 To UBound(brr, 2)
    
16.             crr(i - 1, j - 1) = d(brr(i, 1) & "#" & brr(1, j))
    
17.         Next
    
18.     Next
    
19.     Range("k16").Resize(UBound(crr), UBound(crr, 2)) = crr
    
20. End Sub

复制代码

老师，好像下面这句可以不要
For i = 2 To UBound(arr)
        Set d(arr(i, 1)) = CreateObject("scripting.dictionary") '设置字典嵌套
    Next

zhaogang1960

lzyamo3057 发表于 2013-5-2 21:33

用字典记住该店名出现的行号也可以解决：

1. Sub Macro2()
   
2.     Dim arr, brr, crr(), d As Object, i&, j&, r&
   
3.     Set d = CreateObject("scripting.dictionary")
   
4.     arr = Range("a1").CurrentRegion '原始数据
   
5.     brr = Range("a15").CurrentRegion '目标数据
   
6.     ReDim crr(2 To UBound(brr), 2 To UBound(brr, 2))
   
7.     For i = 2 To UBound(arr)
   
8.         d(arr(i, 1)) = d(arr(i, 1)) & "," & i
   
9.     Next
   
10.     For i = 2 To UBound(brr)
    
11.         a = Split(d(brr(i, 1)), ",")
    
12.         For j = 1 To UBound(a)
    
13.             r = a(j)
    
14.             For l = 2 To UBound(brr, 2)
    
15.                 crr(i, l) = crr(i, l) + arr(r, l)
    
16.             Next
    
17.         Next
    
18.     Next
    
19.     Range("b16").Resize(i - 2, l - 2) = crr
    
20. End Sub
    

复制代码

张雄友

这个我觉得用函数方便些。

dsmch

本来想用字典嵌套代替5个字典的（如果月份更多，可能不止5个字典），没想到大家提出了这么多好的办法，反倒让我受益了不少，多谢多谢！看来这个例子没有体现出嵌套的优越性，有好的例子再补充。

小花鹿

与上面思路一样，既然写了就帖上来吧：
Sub test()
Dim ar1, ar2, br, d, i&, j&
Set d = CreateObject("scripting.dictionary")
ar1 = [a1].CurrentRegion
ar2 = [a15].CurrentRegion
ReDim br(2 To UBound(ar2), 2 To UBound(ar2, 2))
For i = 2 To UBound(ar1)
    For j = 2 To UBound(ar1, 2)
        d(ar1(i, 1) & ar1(1, j)) = d(ar1(i, 1) & ar1(1, j)) + ar1(i, j)
    Next j
Next i
For i = 2 To UBound(ar2)
    For j = 2 To UBound(ar2, 2)
        br(i, j) = d(ar2(i, 1) & ar2(1, j))
    Next j
Next i
[b16].Resize(i - 2, j - 2) = br
End Sub
字典嵌套虽然是一种解法，但是，中看不中用。