字典-提取相关信息

yshcy

提取数据并汇总。数据源在A列和B列，代码没问题。现在，想在代码中增加新的内容：把A列的不重复值，提取到F列中（产品A-D），把B列的不重复值提取到G1到K1，也就是自动生成。目前，F列的内容，以及G1到K1是手工录入的。要考虑到数据源的不断更新。

醉眼看尘世

这样行不行

1. Sub test()
   
2. Dim Dic(1 To 3) As Object, i&, j&, tmpStr$, Arr
   
3. Arr = Sheet1.[a1].CurrentRegion
   
4. For i = 1 To UBound(Dic)
   
5.     Set Dic(i) = CreateObject("scripting.dictionary")
   
6.     Dic(i).comparemode = vbTextCompare
   
7. Next i
   
8. For i = 2 To UBound(Arr, 1)
   
9.     Dic(1)(Arr(i, 1)) = ""
   
10.     Dic(2)(Arr(i, 2)) = ""
    
11.     tmpStr = Arr(i, 1) & Chr(10) & Arr(i, 2)
    
12.     Dic(3)(tmpStr) = Dic(3)(tmpStr) + Arr(i, 3)
    
13. Next i
    
14. ReDim brr(1 To Dic(2).Count + 1, 1 To Dic(1).Count + 1)
    
15. '分布行标
    
16. brr(1, 1) = "汇总"
    
17. i = 1
    
18. For Each k In Dic(2).keys
    
19.     i = i + 1
    
20.     brr(i, 1) = k
    
21. Next k
    
22. '分布列标
    
23. j = 1
    
24. For Each k In Dic(1).keys
    
25.     j = j + 1
    
26.     brr(1, j) = k
    
27. Next k
    
28. For i = 2 To UBound(brr, 1)
    
29.     For j = 2 To UBound(brr, 2)
    
30.         brr(i, j) = Dic(3)(brr(1, j) & Chr(10) & brr(i, 1))
    
31.     Next j
    
32. Next i
    
33. With Sheet1 '返回结果
    
34.     j = .UsedRange.Columns.Count
    
35.     If j > 3 Then .[d1].Resize(1, j - 3).EntireColumn.ClearContents
    
36.     .[f1].Resize(UBound(brr, 1), UBound(brr, 2)) = brr
    
37. End With
    
38. End Sub
    

复制代码

kuangben8

数据透视表，最简单。
多条件查找求和.zip (18.35 KB, 下载次数: 6)

2024-8-21 22:52 上传

点击文件名下载附件

无关岁月

副本多条件查找求和.7z (15 KB, 下载次数: 7)

2024-8-21 23:01 上传

点击文件名下载附件

lsc900707

参考测试附件：

yshcy

kuangben8 发表于 2024-8-21 22:52
数据透视表，最简单。

这里用透视表确实是最快的。主要是想通过这个案例掌握下字典的相关知识。感激你的帮助。

liulang0808

https://club.excelhome.net/threa ... tml?_dsign=b73ad3d6
字典的案例，可以参考的

沈默00

沈默00

参与一下，，，

usedrange

1. Sub tt()
   
2.     Dim dic(2), i%, j%, ar, br, k, t, r%, c%
   
3.     For i = 0 To UBound(dic)
   
4.         Set dic(i) = CreateObject("scripting.dictionary")
   
5.     Next i
   
6.     ar = [a1].CurrentRegion
   
7.     For i = 2 To UBound(ar)
   
8.         For j = 0 To UBound(dic)
   
9.             If j < UBound(dic) Then
   
10.                 dic(j)(ar(i, j + 1)) = ""
    
11.             Else
    
12.                 dic(j)(ar(i, 1) & "|" & ar(i, 2)) = dic(j)(ar(i, 1) & "|" & ar(i, 2)) + ar(i, 3)
    
13.             End If
    
14.         Next j
    
15.     Next i
    
16.     ReDim br(1 To dic(1).Count, 1 To dic(0).Count)
    
17.     [g1].Resize(1, dic(0).Count) = dic(0).keys
    
18.     [f2].Resize(dic(1).Count, 1) = Application.Transpose(dic(1).keys)
    
19.     [f1] = "汇总"
    
20.     For Each k In dic(2).keys
    
21.         t = Split(k, "|")
    
22.         c = [g1:k1].Find(t(0)).Column
    
23.         r = Range("f2:f" & [f1].End(4).Row).Find(t(1)).Row
    
24.         Cells(r, c) = dic(2)(k)
    
25.     Next k
    
26.     For i = 0 To UBound(dic)
    
27.         Set dic(i) = Nothing
    
28.     Next i
    
29. End Sub

复制代码