EXCEL如何用VBA数据字典：除去重复后汇总
使用数组，删除A列中重复的项，然后汇总C列。
A汇总到E，C汇总到F 展开
Sub main()
Set dic = CreateObject("scripting.dictionary") '定义词典
arr = Range("A1:C500") '假设最大行数为500，将A1至C500区域放入数组
For i = 1 To UBound(arr) '从1到数组最大行数循环
If arr(i, 1) <> "" And arr(i, 1) <> "装置" Then '提出空格和标题行
dic(arr(i, 1)) = dic(arr(i, 1)) + arr(i, 3) '用字典去除重复，并且进行数量累加
End If
Next i
[e2].Resize(dic.Count, 1) = Application.Transpose(dic.keys) '将字典的keys(即A列不重复的值)转置并放在E列
[f2].Resize(dic.Count, 1) = Application.Transpose(dic.items) '将字典的kItems（即累加结果)转置并放在E列
End Sub
已赞过
已踩过<
Sub LJLK()
Set d = CreateObject("scripting.dictionary")
[E:F] = ""
For I = 1 To [A65536].End(3).Row
IF CELLS(I,1)<>"" THEN
aa = Cells(I, 1) & "|" & Cells(I, 3)
d(aa) = ""
END IF
Next
arr = d.keys
For x = 0 To UBound(arr)
ss = Split(arr(x), "|")
Cells(x + 1, "e") = ss(0)
Cells(x + 1, "f") = ss(1)
Next
Set d = Nothing
End Sub
Sub caifen()
Dim Myr&, Arr, x&
Dim d, d1, d2, i&, j&
Set d = CreateObject("Scripting.Dictionary")
Set d1 = CreateObject("Scripting.Dictionary")
Set d2 = CreateObject("Scripting.Dictionary")
Myr = [a65536].End(xlUp).Row
Arr = Range("a2:a" & Myr)
Range("c2:e" & Myr).ClearContents
my = Array("MOTO", "诺基亚", "三星", "索爱")
gc = Array("OPPO", "联想", "天语", "金立", "步步高", "波导", "TCL", "酷派")
For x = 1 To UBound(Arr)
For i = 0 To UBound(my)
If InStr(Arr(x, 1), my(i)) > 0 Then
d(Arr(x, 1)) = ""
GoTo 100
End If
Next i
For j = 0 To UBound(gc)
If InStr(Arr(x, 1), gc(j)) > 0 Then
d1(Arr(x, 1)) = ""
GoTo 100
End If
Next j
d2(Arr(x, 1)) = ""
100:
Next x
Range("c2").Resize(UBound(d.keys) + 1, 1) = Application.Transpose(d.keys)
Range("d2").Resize(UBound(d1.keys) + 1, 1) = Application.Transpose(d1.keys)
Range("e2").Resize(UBound(d2.keys) + 1, 1) = Application.Transpose(d2.keys)
End Sub
这是一段VBA代码，主要的作用是将"A"列中的数据按照一定规则分类，并将分类结果分别放置在"C"、"D"、"E"列中。
具体来说，代码中实现的步骤如下：
定义了一些变量，包括Myr、Arr、My、gc、d、d1、d2等，并对它们进行了初始化或赋值。
使用For循环遍历Arr中的每一行数据，并依次判断该行数据中是否包含分类规则中的关键词。
使用Application.Transpose方法将字典对象中的键值转置为一列，并将其赋值给对应的单元格范围。
其中Myr表示"A"列中数据的最后一行，Arr则是将"A2:A"与Myr合并成一个区域，my和gc分别是两个字符串数组，存储了分类规则中的关键词，d、d1、d2是三个字典对象，分别用于存储三个分类结果中的唯一值。
如果包含，则将该行数据的值作为键值存入对应的字典对象d、d1或d2中，并跳过后面的循环。
最后，代码执行完毕后，就会在"C"、"D"、"E"三列中显示按照分类规则分类后的结果。
三、代码详解
1、Set d2 = CreateObject("Scripting.Dictionary") ：针对三个不同的种类，创建d、d1、d2三个字典对象。
2、Myr = [a65536].End(xlUp).Row ：把A列最后一行不为空白的行数赋给变量Myr。
3、Arr = Range("a2:a" & Myr) ：把A2开始的有数据的单元格区域赋给变量Arr。
4、Range("c2:e" & Myr).ClearContents ：把C2到E列单元格区域清空。
5、my = Array("MOTO", "诺基亚", "三星", "索爱") ：VBA函数Array返回一个一维数组，默认下界为0。把Array函数返回的数组赋给变量my(贸易两汉字的首字母)。
6、gc = Array("OPPO", "联想", "天语", "金立", "步步高", "波导", "TCL", "酷派") ：把Array函数返回的数组赋给变量gc(国产两汉字的首字母)。
7、For x = 1 To UBound(Arr) ：在A列原始数据的数组中逐一循环。
8、For i = 0 To UBound(my) ：在my数组中逐一循环。因为有4个贸易机品牌，所以用循环每一个与原始数据比较。
9、If InStr(Arr(x, 1), my(i)) > 0 Then ：VBA函数Instr返回在第1个参数中查找的位置，如果返回结果＝0，表示在第1个参数中没有第2个参数存在。本句的意思是如果找到贸易机品牌的话，执行下面的代码。
10、d1(Arr(x, 1)) = "" ：接上句，如果上面判断成立，就把Arr(x, 1)加入字典d。
11、GoTo 100 ：Goto语句用于无条件地转移到过程中指定的行。这里采用跳出For i循环，一是为了减少循环的次数，比如"MOTO"找到的话，后面3个就不需要找了；二是为了跳过两个小循环之后的其它品牌加入第3个字典的d2(Arr(x, 1)) = ""语句。
12、For j循环与上面相同，为了判断得到国产机类的字典d1。
13、d2(Arr(x, 1)) = "" ：如果上述两个小循环都不满足，那么就加入其它品牌类字典里。
14、Range("c2").Resize(UBound(d.keys) + 1, 1) = Application.Transpose(d.keys) ：最后的3句分别把字典的关键字数组转置后赋给相应的单元格区域。
代码执行后如图实例4-1所示。
图 实例4-1 示例
山菊花版主用了一个字典对象就解决了上述问题。让我们来学习一下。
