EXCEL如何用VBA数据字典：除去重复后汇总

Question

ABC三列数据，需要的结果在EF列
使用数组，删除A列中重复的项，然后汇总C列。
A汇总到E，C汇总到F

Answer 1

以下为代码及注释：

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

Answer 2

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

本回答被提问者和网友采纳

Answer 3

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等，并对它们进行了初始化或赋值。

其中Myr表示"A"列中数据的最后一行，Arr则是将"A2:A"与Myr合并成一个区域，my和gc分别是两个字符串数组，存储了分类规则中的关键词，d、d1、d2是三个字典对象，分别用于存储三个分类结果中的唯一值。

使用For循环遍历Arr中的每一行数据，并依次判断该行数据中是否包含分类规则中的关键词。

如果包含，则将该行数据的值作为键值存入对应的字典对象d、d1或d2中，并跳过后面的循环。

使用Application.Transpose方法将字典对象中的键值转置为一列，并将其赋值给对应的单元格范围。

最后，代码执行完毕后，就会在"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  示例

山菊花版主用了一个字典对象就解决了上述问题。让我们来学习一下。