VBA 字典法学习与例子
Sub 二列多行求和()
Dim arr1, dic, x, arr2(1 To 10, 1 To 2), m%, k% '定义变量
Set dic = CreateObject(\"Scripting.dictionary\") '后期绑定引用字典 arr1 = Range(\"A1\").CurrentRegion '把单元区域装到数组arr1 For x = 2 To UBound(arr1, 1) '循环数组arr1的行
If dic.exists(arr1(x, 1)) Then '判断数组元素arr1(x,1)在字典关键词里是否存在， m = dic(arr1(x, 1)) '如果存在，把关键词arr1(x,1)的条目读出来，在原来的
'基础上累加，通过读取关键词arr1(x,1)的条目，找到在数组arr2那一行上累加 arr2(m, 2) = arr2(m, 2) + arr1(x, 2) '在数组arr2第m行，第2列上累加 Else '如果关键词arr1(x,1)不存在，那么 k = k + 1 '计数
dic(arr1(x, 1)) = k '把数组arr1(x,1)装到字典dic里，条目装一个k, '这个k的作用来给数组arr2中找到存放那一行
arr2(k, 1) = arr1(x, 1) '把数组arr1里的第x行第1列装到数组arr2的第k行，第1列 arr2(k, 2) = arr1(x, 2) '把数组arr1里的第x行第2列装到数组arr2的第k行，第2列 End If Next x
Range(\"E1:F\" & Rows.Count) = \"\" '清空区域，用来存放新的数据 [E1:F1] = Array(\"产品名称\数量\") '填充表头
[E2].Resize(k, 2) = arr2 '把数组arr2读到单元格区域 End Sub
2020-8-31
Sub 多列多行汇总()
Dim dic, arr1, x%, MySt, k%, arr2(1 To 15, 1 To 3), y%, m% Set dic = CreateObject(\"Scripting.dictionary\") arr1 = Range(\"A1\").CurrentRegion For x = 2 To UBound(arr1, 1) MySt = arr1(x, 1) & arr1(x, 2) If dic.exists(MySt) Then
m = dic(MySt)
arr2(m, 3) = arr2(m, 3) + arr1(x, 3) Else k = k + 1 dic(MySt) = k For y = 1 To 3
arr2(k, y) = arr1(x, y) Next y End If Next x
Range(\"E1:G\" & Rows.Count) = \"\"
[E1:G1] = Array(\"产品名称\款号\数量\") [E2].Resize(k, 3) = arr2 End Sub
产品名称 款号 WS-10 WS-10 WS-10 VZ-45 VZ-45 VZ-45 WS-10 VZ-45
A B C A B C A A
数量 1 2 3 1 2 3 99 999
产品名称 款号 WS-10 WS-10 WS-10 VZ-45 VZ-45 VZ-45
A B C A B C
数量 100 2 3 1000
2 3
Sub 删除重复数据－根据A列内容，保存表格内数据最上面一行，删除下面的重复行 Set d = CreateObject(\"scripting.dictionary\")
Set Rng = Nothing
arr = [a1].CurrentRegion
Application.ScreenUpdating = False For j = 1 To UBound(arr) If d.exists(arr(j, 1)) Then If Rng Is Nothing Then
Set Rng = Cells(j, 1) Else
Set Rng = Union(Rng, Cells(j, 1)) End If Else
d(arr(j, 1)) = \"\" End If Next j
If Not Rng Is Nothing Then Rng.EntireRow.Delete Application.ScreenUpdating = True End Sub
客户姓名 月份 消费数量 A1 1 10 A2 1 10 A1 1 10 A2 1 10 A3 2 10 A4 2 10 A5 2 10 A3 2 10 A4 2 10 A5 2 10 A6 3 10 A7 3 10 A6 3 10 A7 3 10 A8 4 10 A4 4 10 A8 4 10 A4 4 10 A5 5 10 A6 5 10 A5 5 10 A6 5 10 A1 6 10 A10 6 10 A1 6 10 A10 6 10 A8 7 10 A9 7 10 A8 7 10 A9 7 10
Sub 根据内容查询对应数据
Dim dic, arr1, arr2, arr3, arr4(1 To 100, 1 To 2), x& y& k& '定义变量 Set dic = CreateObject(\"Scripting.Dictionary\") '后期绑定引用字典 Range(\"H2:I100\") = \"\" '清空原有的数据
arr1 = Range(\"A1\").CurrentRegion '把区域装到数组arr1 arr2 = Range(\"F1\").CurrentRegion '把区域装到数组arr2 For x = 2 To UBound(arr1, 1) '循环数组arr1的行
dic(arr1(x, 1) & \"|\" & arr1(x, 2)) = arr1(x, 3) & \"|\" & arr1(x, 4)
'由于两个条件，而关键字只能装一个条件，所以用&把两件条件连起来，中间用\"|\"分
开
'同理，由于有二个条目，而一个关键词只能对应一个条目，因此我也是用&连接起来，中间用\"|\"分开
'这样就解决了多行多列装入到字典，间接地突破了字典只能装两列
Next x
For y = 2 To UBound(arr2, 1) '循环数组arr2的行
arr3 = VBA.Split(dic(arr2(y, 1) & \"|\" & arr2(y, 2)), \"|\")
'根据arr2(y, 1) & \"|\" & arr2(y, 2)）读字典dic里的条目出来，其实它的条目就是我们 '刚才arr1后面两列的用\"|\"的数据，然后用函数Split切开，根据\"|\"，赋值给数组arr3 '大家一定要明白，Split通过\"|\"切开，赋值给数组arr3 数组arr3是一维数组，且它的上标从0开始
k = k + 1 '累加k
arr4(k, 1) = Val(arr3(0)) '把切开出来的数据放到数组arr4里
arr4(k, 2) = Val(arr3(1)) Next y
[H2].Resize(k, 2) = arr4
Sub 透视表示的汇总()
Dim arr1, dica, dicb, x& k& y& m& n& a& b& arr2() '定义相关的变量 Set dica = CreateObject(\"Scripting.Dictionary\") '创建两个字典 Set dicb = CreateObject(\"Scripting.Dictionary\")
arr1 = Range(\"A1\").CurrentRegion '把区域装入数组arr1
For x = 2 To UBound(arr1, 1) '循环数组arr1的行
If Not dicb.exists(arr1(x, 2)) Then '如果关键字arr1(x,2)不存在，那么 '就把它装入字典dicb里，目的就是为了去重 k = k + 1 '累加k，目的给dicb做条目
dicb(arr1(x, 2)) = k + 1 '这里为什么还要加1呢？ 原因在数组arr2里第一列是产品名称 '第二放型号\"大号\"，第三列放型号\"中号\"，第四列放型号\"小号\"，第五列是行汇总 End If Next x
ReDim arr2(1 To 100, 1 To dicb.Count + 2) For y = 2 To UBound(arr1, 1)
If dica.exists(arr1(y, 1)) Then '如果字典dica里关键字arr1(y,1)存在，那么就累加arr2数据列
a = dica(arr1(y, 1)) '字典dica里关键词arr1(y,1)的条目读出来，目的在是在数组arr2 '里找到累加数组arr2那一行，而数组arr2有五列，具体累加到那一列呢？ b = dicb(arr1(y, 2)) '字典dicb里的关键词arr1(y,2)的字典读出来，来定位到具体累加到数组arr2那一列
arr2(a, b) = arr2(a, b) + arr1(y, 3)
arr2(a, 5) = arr2(a, 2) + arr2(a, 3) + arr2(a, 4) '同一行三种型号相加 Else
m = m + 1 '累加m，目的给dica做条目和数组arr2定位 dica(arr1(y, 1)) = m '把arr1(y,1)装入字典dic2，条目为m n = dicb(arr1(y, 2))
arr2(m, 1) = arr1(y, 1) '把数组arr1的第一列装入arr2里的第一列 arr2(m, n) = arr1(y, 3) '把数组arr1的第三列装入arr2里的第n列 End If Next y
Range(\"F1:J\" & Rows.Count) = \"\"
[F1] = \"产品名称\"
[G1].Resize(1, dicb.Count) = dicb.keys [G1].Offset(0, dicb.Count) = \"行总计\"
[F2].Resize(dica.Count, dicb.Count + 2) = arr2 End Sub
