******************************************************************************
*                                                                            *
*    Excel精英培训数组与字典班第二课课件：字典在VBA中应用                  *
*                                                                            *
*                          ---------兰幻想原创 (lpx)  *
*                                  欢迎转截，但禁止用于商业用途            *
******************************************************************************
一、什么是字典？我们为什么要学它？
字典(Dictionary)是VBA中提供的一个类似二维数组的可以装数据的对象。为什么要把它起名叫字典？因为它
'的使用特征很类似字典。有共有两列，第一列是"字"，第二列是"对字的解释"。
字典和数组很像，但有一个特征是数组不具备的，就是它可以根据存放的内容定位数据，而数组是根据“标”
来定位，如果在数组中查某个元素是否存在，我们除了调用工作表函数外(注：调用工作表函数会拖慢速度)，只能
循环的方法来实现.
看个例子吧:
Sub t1()
Dim arr
arr = Range("a2:b5")
For x = 1 To UBound(arr)
If arr(x, 1) = "C" Then
MsgBox arr(x, 2)
End If
Next x
End Sub
从上面的例子我们就可以看出数组在定位元素时的缺陷，而字典正好可以弥补，利用字典的特征，我们可以完成以下常用功能:
1 提取唯一值
2 快速查
3 多条件汇总
二、字典在哪里？我们如果使用它？
字典对象不是EXCEL程序直接附带的，而是在"c:\windows\system32\scrrun.dll"链接库中，所以我们要想用它，要先调用它.
调用字典有两种方法,
1 引用法:
step 1 :VBE中的工具菜单--引用--浏览---在system32文件夹中到scrrun.dll后点打开即可.
使用dim 变量 as new dictionary 声明后就可以用了
2 创建法
Set d = CreateObject("Scripting.Dictionary") '使用CreateObject创建对字典对象的引用
一向字典内装数据
数组可以一次性的从单元格中取数，而字典呢，只能通过循环来装数据，把字装在第一列，把"内容"装在第二列.
1 使用add方法装
Sub q1()
Dim dic As New Dictionary '声明的一个字典对象
Dim arr
arr = Range("a2:b5")  '把单元格数据装入内存
For x = 1 To UBound(arr)
If Not dic.Exists(arr(x, 1)) Then  '字典的Exists属性可以判断在一个元素字典内的第一列是否存在
dic.Add arr(x, 1), arr(x, 2) '使用add方法向字典内装. 字典.add 第一列内容，第二列内容
End If
Next x
End Sub
2 使用修改式装
Sub q2()
Dim dic As New Dictionary
Dim arr
arr = Range("a2:b5")  '把单元格数据装入内存
For x = 1 To UBound(arr)
dic(arr(x, 1)) = arr(x, 2) '如果arr(x,1)在字典中存在，则使用本次item的值替换原来的第二列值，如果不存在，则会创新一个新的key
Next x
End Sub
二取字典内的详细信息
我们装入字典的目的是为了运算和数据处理，所以装入后我们还要从字典中返回相应的数据和信息
Sub q3()
Dim dic As New Dictionary
Dim arr, arr1
arr = Range("a2:b5")  '把单元格数据装入内存
For x = 1 To UBound(arr)
dic(arr(x, 1)) = arr(x, 2) '如果arr(x,1)在字典中存在，则使用本次item的值替换原来的第二列值，如果不存在，则会创新一个新的key
Next x
MsgBox dic.Count '使用count属性可以返回字典内有多少行
MsgBox dic.Item("B") '或dic("B") ，可以根据第一列的内容直接返回对应的第二列的值，这个VBA数组只能用循环完成
arr1 = dic.Keys '把字典内的第一列值一次性的放入arr1中，构成一个一维数组
MsgBox arr1(0)
Range("d1").Resize(dic.Count) = Application.Transpose(dic.Items) '通过转换把字典的第二列放入单元格中
End Sub
三清除字典的元素
Sub q4()
Dim dic As New Dictionary
Dim arr
arr = Range("a2:b5")  '把单元格数据装入内存
For x = 1 To UBound(arr)
dic(arr(x, 1)) = arr(x, 2) '如果arr(x,1)在字典中存在，则使用本次item的值替换原来的第二列值，如果不存在，则会创新一个新的key
Next x
dic.Remove ("B") '使用remove 可以清除字典内指定的字符，这也是数组做不到的
MsgBox dic.Item("B")
dic.RemoveAll '清空字典
End Sub
Sub w1()
Dim arr
Dim d As New Dictionary
d.CompareMode = TextCompare 'CompareMode属性的值为TextCompare时，可以忽略大小写，默认大小写是不同的
arr = Range("a1:a12")
For x = 1 To UBound(arr)
If Not d.Exists(arr(x, 1)) Then
d.Add arr(x, 1), ""
End If
Next x
Range("c1").Resize(d.Count) = Application.Transpose(d.Keys)
End Sub
下面和数组比试一下速度
Sub w2() '使用字典的耗时是0.04s
t = Timer
Dim arr
Dim d As New Dictionary
arr = Range("a1:a20000")
For x = 1 To UBound(arr)
If Not d.Exists(arr(x, 1)) Then
d.Add arr(x, 1), ""
End If
Next x
Range("c1").Resize(d.Count) = Application.Transpose(d.Keys)
MsgBox Timer - t
End Sub
使用数组
Sub w3() '使用数组的耗时是10s，是字典的250倍
t = Timer
Dim arr, arr1()
arr = Range("a1:a20000")
ReDim arr1(1 To 1)
For x = 1 To UBound(arr)
For y = 1 To UBound(arr1)
If arr(x, 1) = arr1(y) Then
GoTo 100
End If
Next y
k = k + 1
ReDim Preserve arr1(1 To k)
arr1(k) = arr(x, 1)
100:00:00
Next x
Range("d1").Resize(k) = Application.Transpose(arr1)
MsgBox Timer - t
End Sub
1 双向查
Sub e1()
Dim arr
Dim d As New Dictionary
arr = Range("a1:b6")
For x = 1 To UBound(arr) '把城市放入第一列，简写放入第二列
d(arr(x, 1)) = arr(x, 2)
Next x
For x = 1 To UBound(arr) '为了能达到双向查，把简写放入第一列，把城市放入第二列    d(arr(x, 2)) = arr(x, 1)
Next x
MsgBox d("上海")
MsgBox d("sh")
End Sub
2 多条件查
resize函数vbaSub e2()
Dim arr, arr1, arr2(1 To 2, 1 To 2), arr3
Dim d As New Dictionary
arr = Range("a2:d5")
arr1 = Range("a12:b13")
For x = 1 To UBound(arr)
d(arr(x, 1) & "-" & arr(x, 2)) = arr(x, 3) & "-" & arr(x, 4) '把字符进行合并放在字典中
Next x
For y = 1 To UBound(arr1)
arr3 = Split(d(arr1(y, 1) & "-" & arr1(y, 2)), "-") '拆分字符
arr2(y, 1) = arr3(0)
arr2(y, 2) = arr3(1)
Next y
Range("C12").Resize(2, 2) = arr2
End Sub
单条件求和
Sub p1()
Dim d As New Dictionary
Dim arr
arr = Range("b2:c5")
For x = 1 To UBound(arr)
d(arr(x, 1)) = d(arr(x, 1)) + arr(x, 2) '字典中的相同的key进行累加
Next x
Range("e2").Resize(d.Count) = Application.Transpose(d.Keys)
Range("f2").Resize(d.Count) = Application.Transpose(d.Items)
End Sub
多条件求和
Sub e2()
Dim arr, arr1, arr2(1 To 1000, 1 To 2), arr3
Dim d As New Dictionary
arr = Range("a2:c6")
For x = 1 To UBound(arr)
d(arr(x, 1) & "-" & arr(x, 2)) = d(arr(x, 1) & "-" & arr(x, 2)) + arr(x, 3) '把需要汇总的列进行连接    Next x
arr1 = d.Keys
For y = 0 To UBound(arr1)
arr3 = Split(arr1(y), "-") '把连接的产品和型号列进行拆分
arr2(y + 1, 1) = arr3(0)  '拆分后的放进arr2数组中
arr2(y + 1, 2) = arr3(1)
Next y
Range("f2").Resize(d.Count, 2) = arr2
Range("h2").Resize(d.Count) = Application.Transpose(d.Items)
End Sub
多列求和
Sub e3()
Dim arr
Dim d1 As New Dictionary, d2 As New Dictionary, d3 As New Dictionary
arr = Range("a2:d6")
For x = 1 To UBound(arr)
d1(arr(x, 1)) = d1(arr(x, 1)) + arr(x, 2) '利用d1字典汇总数量
d2(arr(x, 1)) = arr(x, 3) '利用d2字典放单价，不汇总
d3(arr(x, 1)) = d3(arr(x, 1)) + arr(x, 4) '利用d3字典汇总金额
Next x
Range("a13").Resize(d1.Count) = Application.Transpose(d1.Keys)    Range("b13").Resize(d1.Count) = Application.Transpose(d1.Items)    Range("c13").Resize(d1.Count) = Application.Transpose(d2.Items)    Range("d13").Resize(d1.Count) = Application.Transpose(d3.Items)  End Sub

版权声明：本站内容均来自互联网，仅供演示用，请勿用于商业和其他非法用途。如果侵犯了您的权益请与我们联系QQ:729038198，我们将在24小时内删除。