关于VBA字典读取问题

f8b1987

Sub 求和()
    Dim arr, d As Object, sh As Worksheet, ar
    Dim i As Integer, j As Byte, k As Byte
    Set d = CreateObject("scripting.dictionary")
    For Each sh In Worksheets
        If sh.Name <> "汇总" Then
            arr = sh.Range("a1").CurrentRegion
            For i = 2 To UBound(arr)
                d(arr(i, 1) & "|" & arr(i, 2)) = d(arr(i, 1) & "|" & arr(i, 2)) + arr(i, 3)
            Next i
            Erase arr
        End If
    Next sh
    ar = Sheets("汇总").Range("a2").CurrentRegion
    For j = 2 To UBound(ar, 1)
        For k = 2 To UBound(ar, 2)
            ar(j, k) = d(ar(1, k) & "|" & ar(j, 1))
        Next k
    Next j
    Sheets("汇总").Range("a2").Resize(UBound(ar, 1), UBound(ar, 2)) = ar
End Sub




看了一下字典用法，有点不理解，写入的字典数据，是如何排列的？读取的时候又如何依据行列一一对应读取的呢？

希望各位能帮忙解释一下。

字典双条件求和.rar (11.54 KB, 下载次数: 789)

2012-5-7 14:26 上传

点击文件名下载附件

shaowu459

哪些地方需要解释？这个还有点不完善的地方，就是汇总表的A列好像没有自动生成吧

shaowu459

1. Sub 求和()
   
2.     Dim arr, d As Object, sh As Worksheet, ar, k1
   
3.     Dim i As Integer, j As Byte, k As Byte
   
4.     Set d = CreateObject("scripting.dictionary")
   
5.     Set d1 = CreateObject("scripting.dictionary")
   
6.    
   
7.     Sheets("汇总").Range("a3:g65535").ClearContents
   
8.    
   
9.     For Each sh In Worksheets
   
10.         If sh.Name <> "汇总" Then
    
11.             arr = sh.Range("a1").CurrentRegion
    
12.             For i = 2 To UBound(arr)
    
13.                 d(arr(i, 1) & "|" & arr(i, 2)) = d(arr(i, 1) & "|" & arr(i, 2)) + arr(i, 3)
    
14.                 d1(arr(i, 2)) = ""
    
15.             Next i
    
16.             Erase arr
    
17.         End If
    
18.     Next sh
    
19. 
    
20. 
    
21.     k1 = d1.keys
    
22. 
    
23.     Sheets("汇总").Range("a3").Resize(d1.Count, 1) = Application.Transpose(k1)
    
24. 
    
25.     ar = Sheets("汇总").Range("a2").CurrentRegion
    
26. 
    
27.     For j = 2 To UBound(ar, 1)
    
28.         For k = 2 To UBound(ar, 2)
    
29.             ar(j, k) = d(ar(1, k) & "|" & ar(j, 1))
    
30.         Next k
    
31.     Next j
    
32.     Sheets("汇总").Range("a2").Resize(UBound(ar, 1), UBound(ar, 2)) = ar
    
33. End Sub
    

复制代码

未修改原代码结构，在源代码的基础上完善了一下，自动生成汇总表的A列内容。

shaowu459

简单的说，如果数据是a,b,c,d,e,f,a，对应的数据是1,2,3,4,5,6,7。这样逐个添加到字典中，例如d("a")=d("a")+1，d("b")=d("b")+1，这样最终字典中的关键字就是6个（a重复过，但是只记录一个关键字），但是6个关键字分别对应的items是8,2,3,4,5,6，因为每次重复的时候就用原来关键字对应的items加上重复的关键字对应的值。

yiyiyicz

1. Sub 求和()
   
2.     Dim arr, d As Object, sh As Worksheet, ar
   
3.     Dim i As Integer, j As Byte, k As Byte
   
4.     Set d = CreateObject("scripting.dictionary")
   
5.     For Each sh In Worksheets '
   
6.         If sh.Name <> "汇总" Then '只要不是名为“汇总”的表
   
7.             arr = sh.Range("a1").CurrentRegion '选定区域
   
8.             For i = 2 To UBound(arr) '循环从数组第2行到数组的最后一行
   
9.                 '字典key的顺序是按照写入顺序排列的
   
10.                 'arr(i, 1) & "|" & arr(i, 2)意为字典key的内容为“日期|用户名称”
    
11.                 'arr(i, 3)意为字典item的内容是“销售额”
    
12.                 d(arr(i, 1) & "|" & arr(i, 2)) = d(arr(i, 1) & "|" & arr(i, 2)) + arr(i, 3)
    
13.             Next i
    
14.             Erase arr '清除数组
    
15.         End If
    
16.     Next sh
    
17.     ar = Sheets("汇总").Range("a2").CurrentRegion
    
18.     For j = 2 To UBound(ar, 1) '数组ar的行数
    
19.         For k = 2 To UBound(ar, 2) '数组ar的列数
    
20.             '依次为
    
21.             '字典key（第2列的顶行,第2行的最左列）=key(4月1日，江苏省）
    
22.             '对应的d.item(4月1日，江苏省)=1751,填入ar(2,2)
    
23.             '而ar(2,2),填入单元格B3
    
24.             ar(j, k) = d(ar(1, k) & "|" & ar(j, 1))
    
25.         Next k
    
26.     Next j
    
27.     Sheets("汇总").Range("a2").Resize(UBound(ar, 1), UBound(ar, 2)) = ar
    
28. End Sub

复制代码

yiyiyicz

实际上，代码第一部分5-16行，是按照“日期|用户名称”这两个参数，形成字典。字典的关键字就是“日期|用户名称”，而与之对应的item是销售额
字典 keys   items  都是一维数列
代码第一部分17-26行，做了一个数组，也就是相当一个矩阵。纵向坐标是用户，横向坐标是日期。
字典关键字“日期|用户名称”，正好就是矩阵的横向坐标与纵向坐标
矩阵中各个元素，就是按照横向坐标与纵向坐标对应关系，一一填入字典的item

f8b1987

shaowu459 发表于 2012-5-7 15:25
未修改原代码结构，在源代码的基础上完善了一下，自动生成汇总表的A列内容。

参考你的方法，我常见一个sheet3（实际表名为sheet1），目的是从sheet2提前用户名称，按日期进行汇总到sheet3中，为何不成功，求指点。

1. Sub 求和问题()
   
2. 
   
3.     Dim arr, d As Object, sh As Worksheet, ar
   
4. 
   
5.     Dim i As Integer, j As Byte, k As Byte
   
6. 
   
7.     Set d = CreateObject("scripting.dictionary")
   
8.     Set d1 = CreateObject("scripting.dictionary")
   
9.     Set d2 = CreateObject("scripting.dictionary")
   
10. 
    
11.             arr = Sheet2.Range("a1").CurrentRegion '选定区域装入数组
    
12. 
    
13.             For i = 1 To UBound(arr) '循环从数组第1行到数组的最后一行
    
14.                 d(arr(i, 1) & "|" & arr(i, 2)) = d(arr(i, 1) & "|" & arr(i, 2)) + arr(i, 3)
    
15.                  d1(arr(i, 1) & "|" & arr(i, 2)) = d1(arr(i, 1) & "|" & arr(i, 2)) + arr(i, 1)
    
16.                   d2(arr(i, 1) & "|" & arr(i, 2)) = d2(arr(i, 1) & "|" & arr(i, 2)) + arr(i, 2)
    
17. Next i
    
18.    k1 = d1.keys
    
19.     k2 = d2.keys
    
20. Sheet3.Range("a1").Resize(d1.Count, 1) = Application.Transpose(d1.Item)
    
21. Sheet3.Range("b1").Resize(d2.Count, 2) = Application.Transpose(d2.Item)
    
22. 
    
23. ar = Sheet3.Range("a1").CurrentRegion
    
24.     For j = 2 To UBound(ar, 1)
    
25.    
    
26. Sheet3.Range("a1").Resize(UBound(ar), 3) = ar
    
27. 
    
28. End Sub
    

复制代码

更新了附件，效果在sheets(sheet1)的透视表

字典条件求和二.rar (15 KB, 下载次数: 408)

2012-5-8 07:54 上传

点击文件名下载附件

nowarmy

学习字典用法的好贴。谢谢楼主的解释。

shaowu459

参考附件。代码应该没出错。

shaowu459

另外提请楼主注意：如果你新加一个表格A，B列没有分表的数据，那么arr=a1.currentregion这句话就返回空了。如果有这样的表格可以加一句on error resume next在代码最前面