这个VBA字典法应该如何写

f8b1987

代码见模块“问题代码”。我的目的是从“分表一”提取数据，做成类似sheet3里面的数据透视表效果。但是我写的代码有点小问题，不知道如何处理，请各位支招。

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

复制代码

运行后，结果显示，相同日期会加到一起，例如，日期“2012-4-1”有相同的，会出现错误的。


具体效果见附件
字典条件求和二.rar (16.06 KB, 下载次数: 343)

2012-5-8 09:04 上传

点击文件名下载附件

zhaojiaoyang200

1. Sub 求和问题()
   
2.    Dim dic, arr, brr, crr, i&, k, t,s$
   
3.    Set dic = CreateObject("Scripting.Dictionary")
   
4.    arr = Sheet2.UsedRange
   
5.    For i = 2 To UBound(arr)
   
6.        s = arr(i, 1) & "|" & arr(i, 2)
   
7.        dic(s) = dic(s) + arr(i, 3)
   
8.    Next
   
9.    k = dic.keys
   
10.    t = dic.items
    
11.    ReDim brr(dic.Count - 1, 1)
    
12.    For i = 0 To dic.Count - 1
    
13.        crr = Split(k(i), "|")
    
14.        brr(i, 0) = crr(0): brr(i, 1) = crr(1)
    
15.     Next
    
16.     With Sheet3
    
17.          .[a2].Resize(dic.Count, 2) = brr
    
18.          .[c2].Resize(dic.Count) = Application.Transpose(t)
    
19.          .[a1:c1] = Sheet2.Range("a1:c1").Value
    
20.     End With
    
21.     Set dic = Nothing
    
22. End Sub

复制代码

jxnu

[code=vb]Sub 求和问题()
    Dim arr, D As Object, ar
    Dim i As Integer, j As Byte

    Set D = CreateObject("scripting.dictionary")
    arr = Sheet2.Range("a1").CurrentRegion '选定区域装入数组
   
    Dim t$
    For i = 1 To UBound(arr) '循环从数组第1行到数组的最后一行
        t = arr(i, 1) & "|" & arr(i, 2)
        If D.exists(t) Then
            D(t) = t & "|" & (--Split(D(t), "|")(2) + arr(i, 3))    '如果有相应的key,则提取对应item的的销售额与现有的相加，再组合后存入字典
        Else
            D(t) = t & "|" & arr(i, 3)                              '如果没有相应的Key，则存入"日期｜名称｜销售额"
        End If
    Next i
   
    Erase arr
    ReDim arr(1 To D.Count, 1 To 3)
    ar = D.items
   
    For i = 1 To UBound(ar) + 1
        For j = 1 To 3
            arr(i, j) = Split(ar(i - 1), "|")(j - 1)
        Next j
    Next i
   
    Sheet3.Range("a1").CurrentRegion.ClearContents
    Sheet3.Range("a1").Resize(UBound(arr), 3) = arr

End Sub

[/code]

smlee

1. Sub auto()
   
2. Dim dic
   
3. Dim arr
   
4. 
   
5. Set dic = CreateObject("scripting.dictionary")
   
6. 
   
7. arr = Sheets(2).[a1:c7]
   
8. 
   
9. For a = 1 To UBound(arr)
   
10. dic(arr(a, 1) & "," & arr(a, 2)) = dic(arr(a, 1) & "," & arr(a, 2)) + arr(a, 3)
    
11. Next
    
12. 
    
13. k = dic.keys
    
14. j = dic.items
    
15. ReDim arr(1 To dic.Count, 1 To 3)
    
16. For a = 1 To dic.Count
    
17.     For b = 1 To 2
    
18.         arr(a, b) = Split(k(a - 1), ",")(b - 1)
    
19.     Next
    
20.     arr(a, 3) = j(a - 1)
    
21. Next
    
22. Sheet3.Range("a1").Resize(UBound(arr), 3) = arr

复制代码

wj2368

1. Sub 求和问题()
   
2.     Dim arr, D As Object, sh As Worksheet, ar, k, s
   
3.     Dim i As Integer, j As Byte
   
4.     Set D = CreateObject("scripting.dictionary")
   
5.             arr = Sheet2.Range("a1").CurrentRegion '选定区域装入数组
   
6.             For i = 1 To UBound(arr) '循环从数组第1行到数组的最后一行
   
7.                 D(arr(i, 1) & "|" & arr(i, 2)) = D(arr(i, 1) & "|" & arr(i, 2)) + arr(i, 3)
   
8. Next i
   
9. s = D.keys
   
10. k = D.items
    
11. ReDim ar(1 To UBound(s) + 1, 1 To 3)
    
12. For j = o To UBound(s)
    
13. ar(j + 1, 1) = Split(s(j), "|")(0)
    
14. ar(j + 1, 2) = Split(s(j), "|")(1)
    
15. ar(j + 1, 3) = k(j)
    
16. Next
    
17. Sheet3.[a1].Resize(UBound(ar), 3) = ar
    
18. Range("a" & UBound(ar) + 1) = "合计"
    
19. Range("c" & UBound(ar) + 1) = Application.Sum(Application.Transpose(Application.Index(ar, , 3)))
    
20. End Sub

复制代码

xiaofx11

1. 
   
2. Sub 求和()
   
3. Dim onr As New Collection, ons As New Collection
   
4. Dim i As Long, j As Long, s As String
   
5. Dim sht As Worksheet
   
6. Dim arr, brr(), crr(), drr()
   
7. Dim dic
   
8. 
   
9. On Error Resume Next
   
10. Set dic = CreateObject("scripting.dictionary")
    
11. 
    
12. For Each sht In Worksheets
    
13.     If sht.Name <> "汇总" Then
    
14.         arr = sht.Range("a1").CurrentRegion
    
15.         For i = 2 To UBound(arr)
    
16.             onr.Add arr(i, 1), CStr(arr(i, 1))
    
17.             ons.Add arr(i, 2), arr(i, 2)
    
18.             dic(arr(i, 1) & "|" & arr(i, 2)) = dic(arr(i, 1) & "|" & arr(i, 2)) + arr(i, 3)
    
19.         Next
    
20.     End If
    
21. Next
    
22. 
    
23. ReDim brr(1 To ons.Count, 1 To onr.Count)
    
24. ReDim crr(1 To ons.Count)
    
25. ReDim drr(1 To onr.Count)
    
26. 
    
27. For i = 1 To ons.Count
    
28.     crr(i) = ons.Item(i)
    
29. Next
    
30. For i = 1 To onr.Count
    
31.     drr(i) = onr.Item(i)
    
32. Next
    
33. 
    
34. For i = 1 To ons.Count
    
35.     For j = 1 To onr.Count
    
36.         s = onr.Item(j) & "|" & ons.Item(i)
    
37.         brr(i, j) = dic(s)
    
38.     Next
    
39. Next
    
40. 
    
41. With Sheet1
    
42.     .UsedRange.ClearContents
    
43.     .Range("a2") = "用户名称"
    
44.     .Range("b3").Resize(ons.Count, onr.Count) = brr
    
45.     .Range("b2").Resize(1, onr.Count) = drr
    
46.     .Range("a3").Resize(ons.Count, 1) = WorksheetFunction.Transpose(crr)
    
47. End With
    
48.    
    
49.    
    
50. End Sub

复制代码

f8b1987

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

复制代码

自己来个

chenzuzhong

1. Sub test()
   
2. Sheets("sheet3").Range("a1:e65536").ClearContents
   
3. Set dic = CreateObject("scripting.dictionary")
   
4. rng = Sheets("·&Ouml;±í&Ograve;&raquo;").Range("a1").CurrentRegion
   
5. For r = 2 To UBound(rng)
   
6.     y = rng(r, 1) & "," & rng(r, 2)
   
7.     dic(y) = dic(y) + rng(r, 3)
   
8. Next
   
9. Sheets("sheet3").Range("a1").Resize(dic.Count, 1) = Application.Transpose(dic.keys)
   
10. Sheets("sheet3").Range("a1").Resize(dic.Count, 1).TextToColumns DataType:=xlDelimited, ConsecutiveDelimiter:=True, comma:=True
    
11. Sheets("sheet3").Range("c1").Resize(dic.Count, 1) = Application.Transpose(dic.items)
    
12. End Sub

复制代码

不知道这样行不行哦