常见字典用法集锦及代码详解
目录
- 前言
- 字典的简介
- 1. 字典对象
- 1.1 Add 方法
- 1.2 Exists 方法
- 1.3 Keys 方法
- 1.4 Items 方法
- 1.5 Remove 方法
- 1.6 RemoveAll 方法
- 2. 实例
- 2.1 实例1. 普通常见的求不重复值问题
- 2.1.1 问题
- 2.1.2 实例代码
- 2.1.3 代码详解
- 2.2 实例2 求多表的不重复值问题
- 2.2.1 问题
- 2.2.2 代码
- 2.2.3 代码详解
- 2.3 实例3 A列中显示1 ~ 1000中被6除余1和余5 的数字
- 2.3.1 问题
- 2.3.2 代码
- 2.3.3 代码详解
- 2.4 实例4 拆分数据不重复
- 2.4.1 问题
- 2.4.2 代码
- 2.4.3 代码详解
- 2.4.4 山菊花版主的代码
- 2.4.5 代码详解
- 2.5 实例5 前期绑定的字典实例
- 2.5.1 问题
- 2.5.2 代码
- 2.5.3 代码详解
- 2.6 实例6 多条件复杂汇总
- 2.6.1 问题
- 2.6.2 代码
- 2.6.3 代码详解
- 2.7 实例7 字典法排序
- 2.7.1 问题
- 2.7.2 代码
- 2.7.3 代码详解
- 2.8 实例8 2级动态数据有效性问题
- 2.8.1 问题
- 2.8.2 代码
- 2.8.3 代码详解
- 2.9 实例9 字典取行数，数组重新赋值
- 2.9.1 问题
- 2.9.2 代码
- 2.9.3 代码详解
- 2.10 实例10 先字典求得行后显示整行数据
- 2.10.1 问题
- 2.10.2 代码
- 2.10.3 代码详解
- 2.11 实例11 关键字赋给两列后用Replace方法
- 2.11.1 问题
- 2.11.2 代码
- 2.11.3 代码详解
- 2.12 实例12 复杂报表汇总
- 2.12.1 问题的提出 ：
- 2.12.2 代码
- 2.12.3 代码详解
- 3. 后语
前言
凡是上过学校的人都使用过字典，从新华字典、成语词典，到英汉字典以及各种各样数不胜数的专业字典，字典是上学必备的、经常查阅的工具书。有了它们，我们可以很方便的通过查找某个关键字，进而查到这个关键字的种种解释，非常快捷实用。
凡是上过 EH 论坛的想学习VBA里面字典用法的，几乎都看过研究过 northwolves 狼版主、oobird版主的有关字典的精华贴和经典代码。我也是从这里接触到和学习到字典的，在此，对他们表示深深的谢意，同时也对很多把字典用得出神入化的高手们致敬，从他们那里我们也学到了很多，也得到了提高。
字典对象只有 4个属性 和 6个方法 ，相对其它的对象要简洁得多，而且容易理解使用方便，功能强大，运行速度非常快，效率极高。深受大家的喜爱。
本文希望通过对一些字典应用的典型实例的代码的详细解释来给初次接触字典和想要进一步了解字典用法的朋友提供一点备查的参考资料，希望大家能喜欢。
给代码注释估计是大家都怕做的，因为往往是出力不讨好的，稍不留神或者自己确实理解得不对，还会贻误他人。所以下面的这些注释如果有不对或者不妥当的地方，请大家跟帖时指正批评，及时改正。
字典的简介
字典（Dictionary）对象是微软Windows脚本语言中的一个很有用的对象。
附带提一下，有名的 正则表达式（RegExp）对象和能方便处理驱动器、文件夹和文件的（FileSystemObject ）对象也是微软Windows脚本语言中的一份子。
字典对象相当于一种联合数组，它是由具有唯一性的关键字（Key）和它的项（Item）联合组成。就好像一本字典书一样，是由很多生字和对它们对应的注解所组成。比如字典的 “典” 字的解释是这样的：
“典” 字就是具有唯一性的关键字，后面的解释就是它的项，和“典”字联合组成一对数据。
常用关键字英汉对照：
| Dictionary | 字典 |
| Key | 关键字 |
| Item | 项，或者译为 条目 |
1. 字典对象
字典对象的方法有6个：Add方法、Keys方法、Items方法、Exists方法、Remove方法、RemoveAll方法。
1.1 Add 方法
向 Dictionary 对象中添加一个关键字项目对。
-
语法：
object.Add (key, item) -
参数：
数说明 object 必选项。总是一个 Dictionary 对象的名称。 key 必选项。与被添加的 item 相关联的 key。 item 必选项。与被添加的 key 相关联的 item 说明：如果 key 已经存在，那么将导致一个错误。
-
常用语句：
Dim d Set d = CreateObject("Scripting.Dictionary") d.Add "a", "Athens" d.Add "b", "Belgrade" d.Add "c", "Cairo" -
代码详解：
1）Dim d： 创建变量，也称为声明变量。变量d声明为可变型数据类型(Variant)，d后面没有写数据类型，默认就是可变型数据类型(Variant)。也有写成Dim d As Object的，声明为 对象 。
2）Set d = CreateObject("Scripting.Dictionary")：创建字典对象，并把字典对象赋给变量d。这是最常用的一句代码。所谓的 “后期绑定” 。用了这句代码就不用先引用 C:\windows\system32\scrrun.dll了。
3）d.Add "a", "Athens"：添加一关键字"a"和对应于它的项”Athens”。
4）d.Add "b", "Belgrade"：添加一关键字"b"和对应于它的项"Belgrade"。
5） d.Add "c", "Cairo"：添加一关键字"c"和对应于它的项"Cairo"。
1.2 Exists 方法
如果 Dictionary 对象中存在所指定的关键字则返回 true，否则返回 false。
-
语法：
object.Exists(key) -
参数:
参数说明 object 必选项。总是一个 Dictionary 对象的名称。 key 必选项。需要在 Dictionary 对象中搜索的 key 值。 -
常用语句：
Dim d, msg$ Set d = CreateObject("Scripting.Dictionary") d.Add "a", "Athens" d.Add "b", "Belgrade" d.Add "c", "Cairo" If d.Exists("c") Thenmsg = "指定的关键字已经存在。" Elsemsg = "指定的关键字不存在。" End If
-
代码详解：
1）Dim d, msg$ ：声明变量，d见前例；msg$ 声明为字符串数据类型(String)，一般写法为Dim msg As String。String 的类型声明字符为美元号 ($)。
2）If d.Exists("c") Then：如果字典中存在关键字"c"，那么执行下面的语句。
3）msg = "指定的关键字已经存在。"：把 "指定的关键字已经存在。" 字符串 赋给变量 msg。
4）Else ：否则执行下面的语句。
5）msg = "指定的关键字不存在。" ：把 "指定的关键字不存在。" 字符串 赋给变量msg。
6）End If ：结束If …Else…Endif判断。
1.3 Keys 方法
返回一个数组，其中包含了一个 Dictionary 对象中的全部现有的关键字。
-
语法：
object.Keys()其中 object 总是一个 Dictionary 对象的名称。
-
常用语句：
Dim d, k Set d = CreateObject("Scripting.Dictionary") d.Add "a", "Athens" d.Add "b", "Belgrade" d.Add "c", "Cairo" k=d.Keys [B1].Resize(d.Count,1)=Application.Transpose(k)
-
代码详解：
1）Dim d, k ：声明变量，d见前例；k默认是 可变型数据类型 (Variant)。
2）k=d.Keys：把字典中存在的所有的关键字赋给变量k。得到的是一个一维数组，下限为0，上限为d.Count-1。这是数组的默认形式。
3）[B1].Resize(d.Count,1)=Application.Transpose(k) ：这句代码是很常用很经典的代码，所以这里要多说一些：
Resize是 Range对象 的一个属性，用于调整指定区域的大小，它有两个参数：
①、第一个是行数，本例是d.Count，指的是字典中关键字的数量，整本字典中有多少个关键字，本例d.Count=3，因为有 3 个关键字。呵呵，是不是说多了。
②、第二个是列数，本例是1。这样：
＝左边的意思就是：把一个单元格B1调整为以B1开始的一列单元格区域，行数等于字典中关键字的数量d.Count，就是把单元格B1调整为单元格区域B1：B3了。
＝右边的k是个一维数组，是水平排列的。
我们知道 Excel 工作表函数里面有个转置函数 Transpose，用它可以 把水平排列的置换成竖向排列。但是在 VBA 中不能直接使用该工作表函数，需要通过Application对象的WorksheetFunction属性来使用它。所以完整的写法是Application. WorksheetFunction.Transpose(k)，中间的WorksheetFunction可省略。
~现在可以解释这句代码了：
把字典中所有的关键字赋给以B1单元格开始的单元格区域中。
1.4 Items 方法
返回一个 数组，其中包含了一个 Dictionary 对象中的所有项目。
-
语法：
object.Items( )其中 object 总是一个 Dictionary 对象的名称。
-
常用语句：
Dim d, t Set d = CreateObject("Scripting.Dictionary") d.Add "a", "Athens" d.Add "b", "Belgrade" d.Add "c", "Cairo" t=d.Items [C1].Resize(d.Count,1)=Application.Transpose(t) -
代码详解：
1）Dim d, t ：声明变量，d见前例；t默认是可变型数据类型(Variant)。
2）t=d.Items ：把字典中所有的关键字对应的项赋给变量t。得到的也是一个一维数组，下限为0，上限为d.Count-1。这是数组的默认形式。
3）[C1].Resize(d.Count,1)=Application.Transpose(t) ：有了上面Keys方法的解释这句代码就不用多说了，就是把字典中所有的关键字对应的项赋给以C1单元格开始的单元格区域中。
1.5 Remove 方法
Remove 方法从一个 Dictionary 对象中 清除 一个关键字，项目对。
-
语法：
object.Remove(key )其中 object 总是一个 Dictionary 对象的名称。
key：必选项。key 与要从 Dictionary 对象中删除的关键字、项目对相关联。
说明：如果所 指定的关键字，项目对不存在，那么将导致一个 错误 。
-
常用语句：
Dim d Set d = CreateObject("Scripting.Dictionary") d.Add "a", "Athens" d.Add "b", "Belgrade" d.Add "c", "Cairo" ' …… d.Remove(“b”) -
代码详解：
1）d.Remove("b")：清除字典中 "b" 关键字和与它对应的项。清除之后，现在字典里只有2个关键字了。
1.6 RemoveAll 方法
RemoveAll 方法从一个 Dictionary 对象中清除所有的 关键字，项目对。
-
语法：
object.RemoveAll()其中 object 总是一个 Dictionary 对象的名称。
-
常用语句：
Dim d Set d = CreateObject("Scripting.Dictionary") d.Add "a", "Athens" d.Add "b", "Belgrade" d.Add "c", "Cairo" ' …… d.RemoveAll -
代码详解：
1）d.RemoveAll：清除字典中所有的数据。也就是清空这字典，然后可以添加新的关键字和项，形成一本新字典。
字典对象的属性有4个：Count属性、Key属性、Item属性、CompareMode属性。
-
① Count 属性：
属性说明 Count 返回一个Dictionary 对象中的项目数。只读属性。 object.Count：其中 object一个字典对象的名称。
常用语句：
Dim d,n% Set d = CreateObject("Scripting.Dictionary") d.Add "a", "Athens" d.Add "b", "Belgrade" d.Add "c", "Cairo" n = d.Count代码详解：
1）Dim d, n% ：声明变量，d见前例；n被声明为整型数据类型(Integer)。一般写法为Dim n As Integer 。 Integer 的类型声明字符为百分比号 (%)。
2）n = d.Count ：把字典中所有的关键字的数量赋给变量n。本例得到的是3。
-
② Key 属性：
在 Dictionary 对象中设置一个 key。
语法：
object.Key(key) = newkey参数：
参数说明 object 必选项。总是一个字典 (Dictionary) 对象的名称。 key 被改变的 key 值。 newkey 必选项。替换所指定的 key 的新值。 说明：如果在改变一个 key 时没有发现该 key，那么将创建一个新的 key 并且其相关联的 item 被设置为空。
常用语句：
Dim d Set d = CreateObject("Scripting.Dictionary") d.Add "a", "Athens" d.Add "b", "Belgrade" d.Add "c", "Cairo" d.Key("c") = "d"
代码详解：
1）d.Key("c") = "d" ：用新的关键字"d"来替换指定的关键字"c"，这时，字典中就没有关键字c了，只有关键字d了，与d对应的项是"Cairo"。
-
③ Item 属性：
在一个 Dictionary 对象中设置或者返回所指定 key 的 item。对于集合，则根据所指定的 key 返回一个 item。读 / 写。
语法：
object.Item(key)[ = newitem]参数：
参数说明 object 必选项。总是一个Dictionary 对象的名称。 key 与要被查找或添加的 item 相关联的 key。 newitem 可选项。仅适用于 Dictionary 对象；newitem 就是与所指定的 key 相关联的新值。 说明：如果在改变一个 key 的时候没有找到该 item，那么将利用所指定的 newitem 创建一个新的 key。如果在试图返回一个已有项目的时候没有找到 key，那么将创建一个新的 key 且其相关的项目被设置为空。
常用语句：
Dim d Set d = CreateObject("Scripting.Dictionary") d.Add "a", "Athens" d.Add "b", "Belgrade" d.Add "c", "Cairo" MsgBox d.Item("c")
代码详解：
1）d.Item("c") ：获取指定的关键字"c"对应的项。
2）MsgBox ：是一个 VBA 函数，用消息框显示。如果要详细了解MsgBox函数的，可参见我的另一篇文章 常用VBA函数精选合集。
-
④ CompareMode 属性：
设置或者返回在 Dictionary 对象中进行 字符串关键字比较 时所使用的 比较模式。
语法：
object.CompareMode[ = compare]
参数：
参数说明 object 必选项。总是一个Dictionary 对象的名称。 compare 可选项。如果提供了此项，compare 就是一个代表比较模式的值。
可以使用的值是 0 (二进制)、1 (文本)、 2 (数据库)。说明：如果试图改变一个已经包含有数据的 Dictionary 对象的比较模式，那么将导致一个错误。
常用语句：
Dim d Set d = CreateObject("Scripting.Dictionary") d.CompareMode = vbTextCompare d.Add "a", "Athens" d.Add "b", "Belgrade" d.Add "c", "Cairo" d.Add " B ", " Baltimore"
代码详解：
1）d.CompareMode = vbTextCompare ：设置字典的比较模式是文本，在这种比较模式下 不区分关键字的大小写 ，即关键字”b”和”B”是一样的。vbTextCompare的值为1，所以上式也可写为 d.CompareMode =1 。如果设置为vbBinaryCompare（值为0），则执行 二进制比较 ，即 区分关键字的大小写，此种情况下关键字”b”和”B”被认为是不一样的。
2）d.Add " B ", " Baltimore" ：添加一关键字”B”和对应于它的项”Baltimore”。由于前面已经设置了比较模式为文本模式，不区分关键字的大小写，即关键字”b”和”B”是一样的，此时发生错误添加失败，因为字典中已经存在”b”了，字典中的关键字是唯一的，不能添加重复的关键字。
-
2. 实例
2.1 实例1. 普通常见的求不重复值问题
2.1.1 问题
表格中人员有很多是重复的，要求编写一段代码，把重复的人员姓名以及重复的次数求出来，复制到另一个表格中。
如图实例1－1所示。
图 实例1-12.1.2 实例代码
Sub cfz()Dim i&, Myr&, ArrDim d, k, tSet d = CreateObject("Scripting.Dictionary")Myr = Sheet1.[a65536].End(xlUp).RowArr = Sheet1.Range("a1:g" & Myr)For i = 2 To UBound(Arr)d(Arr(i, 3)) = d(Arr(i, 3)) + 1Nextk = d.keyst = d.itemsSheet2.Activate[a2].Resize(d.Count, 1) = Application.Transpose(k)[b2].Resize(d.Count, 1) = Application.Transpose(t)[a1].Resize(1, 2) = Array("姓名", "重复个数")Set d = Nothing End Sub2.1.3 代码详解
Dim i&, Myr&, Arr ：变量i和Myr声明为长整型变量。 也可以写为 Dim Myr As Long 。Long的类型声明字符为(&)。Arr后面没有写明数据类型，默认就是可变型数据类型(Variant)。
Set d = CreateObject("Scripting.Dictionary")：创建字典对象，并把字典对象赋给变量d。这是最常用的一句代码。所谓的“后期绑定”。用了这句代码就不用先引用c:\windows\system32\scrrun.dll了。
Myr = Sheet1.[a65536].End(xlUp).Row ：把表1的A列最后一行不为空白的行数赋给变量Myr。这里用了Range对象的 End 属性，它有4个方向参数，此处的xlUp表示向上，它的值为3，所以也可写成End(3)。xlDown表示向下，它的值为4；xlToLeft表示向左，它的值为1；xlToRight表示向右，它的值为2。
Arr = Sheet1.Range("a1:g" & Myr)：把表1的A1到G列最后一行不为空白的 单元格区域的值赋给变量Arr。这样Arr就是个 二维数组 了，用数组替代单元格引用可对执行代码的速度提高很多很多。
For i = 2 To UBound(Arr) ：For…Next 循环结构，从2开始到数组的最大上界值之间循环。因为数组的第一行是表头。Ubound是VBA函数，返回数组的指定维数的最大可用上界。
d(Arr(i, 3)) = d(Arr(i, 3)) + 1 ：Arr(i,3)在本例是姓名列，也就是关键字列，举个例子，假如Arr(i,3)=”张三”，这句代码的意思就是把关键字”张三”加入字典，d(key)等于关键字key对应的项，每出现一次这个关键字，它的项的值就增加1。起到了按关键字累加的作用，也正因为有这个作用，所以可使用字典来进行各种汇总统计。后面要讲的实例会充分的展现这个作用。
k=d.keys ：把字典d中存在的所有的关键字赋给变量k。得到的是一个一维数组，下限为0，上限为d.Count-1。Keys是字典的方法，前面已经讲过了。
t=d.items ：把字典d中存在的所有的关键字对应的项赋给变量t。得到的也是一个一维数组，下限为0，上限为d.Count-1。Items也是字典的方法，前面也已经讲过了。
Sheet2.Activate ：激活表2；
[a2].Resize(d.Count, 1) = Application.Transpose(k) ：把字典d中所有的关键字赋给以a2单元格开始的单元格区域中。详细的解释请见前面的keys方法一节。
[b2].Resize(d.Count, 1) = Application.Transpose(t) ：把字典d中所有的关键字对应的项赋给以b2单元格开始的单元格区域中。
[a1].Resize(1, 2) = Array("姓名", "重复个数") ：Array是一个VBA函数，返回一个下界为0的一维数组。一维数组可以看作是水平排列的，所以赋值给水平的单元格区域不需要用转置函数了。这里作为表头一次性输入。
Set d = Nothing ：释放字典内存。
代码执行后如图实例1-2所示。
图 实例1-2实例1文件：点击下载 提取码：t34n
2.2 实例2 求多表的不重复值问题
2.2.1 问题
一工作簿里面有3张工作表上，每张表格的A列都是姓名列，所有这些姓名中有些是重复的，要求编写一段代码，在另一个工作表上显示不重复的姓名。
如图实例2－1所示
图 实例2-1这个问题也很适合用字典来解决。代码如下：
2.2.2 代码
Sub bcfz()Dim i&, Myr&, ArrDim d, k, t, Sht As WorksheetSet d = CreateObject("Scripting.Dictionary")For Each Sht In SheetsIf Sht.Name <> "Sheet4" ThenMyr = Sht.[a65536].End(xlUp).RowArr = Sht.Range("a2:a" & Myr)For i = 1 To UBound(Arr)d(Arr(i, 1)) = ""NextEnd IfNextk = d.keysSheet4.[a3].Resize(d.Count, 1) = Application.Transpose(k)Set d = Nothing End Sub2.2.3 代码详解
代码执行后如图实例2-2所示：
图 实例2-2实例2文件：点击下载 提取码：snfv
2.3 实例3 A列中显示1 ~ 1000中被6除余1和余5 的数字
2.3.1 问题
有1、2、3…1000一千个数字，要求编写一段代码，在工作表的A列显示这些数被6除余1和余5的数字。
2.3.2 代码
Sub 余1余5() ‘by:狼版主Dim dic As Object, i As Long, arrSet dic = CreateObject("Scripting.Dictionary")For i = 1 To 1000dic.Add i & IIf(Abs(i Mod 6 - 3) = 2, "@", ""), ""Nextarr = WorksheetFunction.Transpose(Filter(dic.keys, "@"))[a1].Resize(UBound(arr), 1) = arr[a:a].Replace "@", ""Set dic = Nothing End Sub2.3.3 代码详解
Dim dic As Object, i As Long, arr ：也可把字典变量dic声明为对象(Object)，i As Long是规范的写法，也可写成i& 。
dic.Add i & IIf(Abs(i Mod 6 - 3) = 2, "@", ""), "" ：这句代码的内容比较多，用了两个VBA函数IIf和Abs，用了一个Mod运算符。i Mod 6就是每一个数除6的余数，题目中有两个要求：余1和余5，为了从1到1000都同时能满足这两个要求，所以用了Abs(i Mod 6 - 3) = 2 ，Abs是取绝对值函数。另一个VBA函数IIf是根据判断条件返回结果，和If…Then判断结果类似；IIf(Abs(i Mod 6 - 3) = 2, "@", "") 这段的意思是如果符合判断条件，返回”@”否则返回空””。 i & IIf(Abs(i Mod 6 - 3) = 2, "@", "")的意思是把这个数与”@”或者""连起来作为关键字加入字典dic，关键字相对应的项为空。比如当i=1时，1是满足上述表达式的，就把”1@” 作为关键字加入字典dic；当i=2时，2不满足上述表达式，就把”2” 作为关键字加入字典dic，关键字相对应的项都为空。
arr = WorksheetFunction.Transpose(Filter(dic.keys, "@")) ：这句代码的内容分为3部分，第1部分是Filter(dic.keys, "@") 其中的 Filter 是一个 VBA 函数，VBA 函数就是可以直接在代码中使用的，我们平常使用的函数叫工作表函数，如Sum、Sumif、Transpose 等等。Filter 函数要求在一维数组中筛选出符合条件的另一个一维数组，式中的dic.keys正是一个一维数组。这里的筛选条件是“@”，也就是把字典关键字中含有@ 的关键字筛选出来组成一个新的一维数组，其下标从零开始。第2部分是用工作表函数 Transpose 转置这个新的一维数组，工作表函数的使用在前面keys方法一节已经说过了；第2部分是把转置以后的值赋给数组变量Arr。
~呵呵，狼版主的代码是短了，我的解释却太长了。
[a1].Resize(UBound(arr), 1) = arr ：把数组 Arr 赋给 [a1] 单元格开始的区域中。
[a:a].Replace "@", "" ：把A列中的所有的@都替换为空白，只剩下数字了。
代码详解的4代码执行后，如图实例3-1所示：
图实例3-1 示例代码全部执行后如图实例3-2所示：
图实例3-2 示例实例3文件：点击下载 提取码：d2c1
2.4 实例4 拆分数据不重复
2.4.1 问题
有一列各种手机品牌型号的数据，要求编写一段代码，按照品牌划分成没有重复数据的三大类。
2.4.2 代码
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).RowArr = Range("a2:a" & Myr)Range("c2:e" & Myr).ClearContentsmy = 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 Thend(Arr(x, 1)) = ""GoTo 100End IfNext iFor j = 0 To UBound(gc)If InStr(Arr(x, 1), gc(j)) > 0 Thend1(Arr(x, 1)) = ""GoTo 100End IfNext jd2(Arr(x, 1)) = ""100:Next xRange("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 Sub2.4.3 代码详解
代码执行后如图实例4-1所示：
图 实例4-1 示例山菊花版主用了一个字典对象就解决了上述问题。让我们来学习一下：
2.4.4 山菊花版主的代码
Sub 拆分()Dim pp1$, pp2$, nRow%, ds, Brr(), s(1 To 3) As IntegerSet ds = CreateObject("scripting.dictionary")pp1 = Join(WorksheetFunction.Transpose(Range(Range("g2"), Range("g1").End(xlDown))), ",")pp2 = Join(WorksheetFunction.Transpose(Range(Range("h2"), Range("h1").End(xlDown))), ",")nRow = Range("a1").End(xlDown).RowArr = Range("a1:a" & nRow)ReDim Brr(1 To nRow, 1 To 3)For i = 2 To nRowIf Not ds.Exists(Arr(i, 1)) Thends(Arr(i, 1)) = ""If pp1 Like "*" & Left(Arr(i, 1), 2) & "*" Thens(1) = s(1) + 1Brr(s(1), 1) = Arr(i, 1)ElseIf pp2 Like "*" & Left(Arr(i, 1), 2) & "*" Thens(2) = s(2) + 1Brr(s(2), 2) = Arr(i, 1)Elses(3) = s(3) + 1Brr(s(3), 3) = Arr(i, 1)End IfEnd IfNextRange("c2:e" & nRow) = Brr End Sub2.4.5 代码详解
pp1 = Join(WorksheetFunction.Transpose(Range(Range("g2"), Range("g1").End(xlDown))), ",")
这句代码用了两个 VBA 函数 Join 和 Transpose ，Range("g1").End(xlDown)从G1单元格往下直到最下面的单元格，遇到空白格就停止。因为本例的G14、G15单元格有另外的数据存在，如果还是用Range("g65536").End(xlUp)，那么就会把不需要的数据带进去，造成结果出错。Transpose 转置函数，前面已经介绍过了。Join函数是通过连接某个数组中的多个子字符串而创建的一个字符串，本句代码执行后得到：
pp1 = “MOTO, 诺基亚, 三星, 索爱”；
pp2 一句同上句一样，得到另一个字符串。
nRow = Range("a1").End(xlDown).Row ：把A列最后一行不为空白的行数赋给整型变量nRow。
Arr = Range("a1:a" & nRow) ：把A列A1开始的有数据的单元格区域赋给变量Arr。
ReDim Brr(1 To nRow, 1 To 3) ：用于为动态数组变量Brr重新分配存储空间。第一维的下界从1到上界nRow，第二维从1到3。
For i = 2 To nRow ：从2到 nRow逐一循环。
If Not ds.Exists(Arr(i, 1)) Then ：如果字典ds中不存在关键字Arr(i, 1)
ds(Arr(i, 1)) = "" ：把Arr(i, 1)作为关键字加入字典ds。
If pp1 Like "*" & Left(Arr(i, 1), 2) & "*" Then ：这里山版主用了比较运算符Like来比较pp1和取自Arr(i, 1)左边两个字符，再在前后加任意字符组成的字符串，如果满足条件为真，那么执行下面的语句。
s(1) = s(1) + 1 ：数组s的第一个元素+1以后赋给数组s的第一个元素。
Brr(s(1), 1) = Arr(i, 1) ：把这个关键字赋给 第2维 为1的另一个数组Brr，也就是我们要求的贸易机类。pp1字符串里都是贸易机类的品牌。
ElseIf pp2 Like "*" & Left(Arr(i, 1), 2) & "*" Then ：同样，如果满足国产品牌类这个条件，那么执行下面的代码。
s(2) = s(2) + 1 ：数组s的第二个元素+1以后赋给数组s的第二个元素。
Brr(s(2), 2) = Arr(i, 1) ：把这个关键字赋给 第2维 为2的另一个数组Brr，也就是我们要求的国产品牌类。pp2字符串里都是国产品牌类的品牌。
s(3) = s(3) + 1 ：前如果条件都不满足时，数组s的第三个元素+1以后赋给数组s的第三个元素。
Brr(s(3), 3) = Arr(i, 1) ：把这个关键字赋给 第3维 为1的另一个数组Brr，也就是我们要求的其它品牌类。
Range("c2:e" & nRow) = Brr ：把数组Brr赋给[c2]单元格开始的区域中。
实例4文件：点击下载 提取码：nrhi
2.5 实例5 前期绑定的字典实例
2.5.1 问题
有多列多行数据，其中有重复的行，要求编写一段代码，求得不重复的行数据。
如图实例5-1所示：
图 实例5-1 示例2.5.2 代码
Sub 保留原数据() 'by:ldy888'前期绑定，需先引用c:\windows\system32\scrrun.dllDim d As New Dictionary,tFor i = 2 To 5Set d(Cells(i, 1) & "") = Range(Cells(i, 1), Cells(i, 4))Nextt=d.items [A11].Resize(d.Count, 4) = Application.Transpose(Application.Transpose(t)) End Sub2.5.3 代码详解
Dim d As New Dictionary, t ：本段代码需要先引用微软的脚本运行时库 Microsoft Scripting Runtime，可在 VBE 窗口，从菜单－工具－引用，然后勾选Microsoft Scripting Runtime，或者点击浏览，在添加引用对话框中选择c:\windows\system32\scrrun.dll，并打开，确定。完成引用。在本声明语句中把字典d声明为New Dictionary。这就是 “ 前期绑定 ” 了。上面的实例用的是创建对象语句：
Set d = CreateObject("Scripting.Dictionary")，称为 “ 后期绑定 ” ，不需要先引用脚本运行时库。
Set d(Cells(i, 1) & "") = Range(Cells(i, 1), Cells(i, 4))：把单元格对象加入字典，它对应的项是同一行的单元格区域。注意，这里用了Set，和前面的几例不一样哦。如果用 Typename(d(Cells(i,1) & ""))，得到的是一个Range对象。这里的Cells(i, 1) & ""也可以用Cells(i, 1).Value来代替。
t=d.items ：把字典d中存在的所有的关键字对应的项赋给变量t。得到的是一个一维数组，下限为0，上限为d.Count-1。
[A11].Resize(d.Count, 4) = Application.Transpose(Application.Transpose(t)) ：这句用了两次工作表转置函数Transpose之后赋给A11单元格开始的区域中。
代码执行后如图实例5-2所示：
图 实例5-2示例实例5文件：点击下载 提取码：kr3o
2.6 实例6 多条件复杂汇总
2.6.1 问题
有一个表格，需要对其中多个条件相同的数量进行合并汇总，并且要有汇总的明细数据，要求编写一段代码，实现这样的合并同类项的要求。
2.6.2 代码
Sub kf2() ‘by:oobirdDim d As Object, a, b, j%, w!Dim ss$, n%, xMe.UsedRange.Offset(3, 0) = ""a = Sheet1.Range(Sheet1.[a4], Sheet1.[i65536].End(xlUp))Set d = CreateObject("scripting.dictionary")ReDim b(1 To UBound(a), 1 To 8)For i = 1 To UBound(a)ss = a(i, 1) & a(i, 2) & a(i, 4) & a(i, 5) & a(i, 6) & a(i, 8) If Not d.Exists(ss) Thenn = n + 1d.Add ss, nb(n, 1) = a(i, 2): b(n, 2) = a(i, 5): b(n, 3) = a(i, 6): b(n, 4) = a(i, 4)b(n, 5) = a(i, 1): b(n, 6) = a(i, 8): b(n, 7) = a(i, 9)Elseb(d(ss), 7) = b(d(ss), 7) & "+" & a(i, 9)End IfNextFor i = 1 To d.Countx = Split(b(i, 7), "+")For j = 0 To UBound(x)w = w + x(j)Next jb(i, 8) = b(i, 5) * b(i, 6) * w / 100: w = 0Next[b4].Resize(n, 8) = b End Sub2.6.3 代码详解
代码执行后如图实例6-1所示：
实例 6 文件：点击下载 提取码：ytp6
2.7 实例7 字典法排序
2.7.1 问题
A列B列是按顺序排列的全部股票代码和股票名称，C列D列和E列F列是另外按条件筛选出来的无序的数据， 要求编写一段代码，将它们排列到与A列相同的股票行里面。
代码执行前如图实例7-1所示：
图 实例7-1示例2.7.2 代码
Private Sub CommandButton1_Click() ‘by:oobirdDim d As Object, rng, i%, j%, arrSet d = CreateObject("Scripting.Dictionary")rng = Range("a3:f" & [a65536].End(xlUp).Row)ReDim arr(1 To UBound(rng), 1 To 4)For i = 1 To UBound(rng) d(CStr(rng(i, 1))) = iNext iFor j = 3 To 5 Step 2For i = 1 To Cells(65536, j).End(xlUp).Row - 2If d(CStr(rng(i, j))) <> "" Thenarr(d(CStr(rng(i, j))), j - 2) = rng(i, j) arr(d(CStr(rng(i, j))), j - 1) = rng(i, j + 1)End IfNext iNext j[c3].Resize(UBound(rng), 4) = arr End Sub2.7.3 代码详解
代码执行后如图实例7-2所示：
图 实例7-2示例实例 7 文件：点击下载 提取码：3ijp
2.8 实例8 2级动态数据有效性问题
2.8.1 问题
A列是源名称，中间有空格，B列为各个源名称对应的数目不同的代号，C列是目标名称来源于源名称，要求在C列设置不重复的、没有空格的数据有效性供选择；同时D列目标代号，要求随着C列选择的目标名称的不同，提供对应的代号供选择，是为第2级数据有效性。
代码执行前如图实例8-1所示：
图 实例8-1示例2.8.2 代码
Private Sub Worksheet_SelectionChange(ByVal Target As Range)If Target.Count > 1 Then Exit SubIf Target.Column <> 4 And Target.Column <> 3 Then Exit SubDim d, i&, Myr&, Arr, r%, Arr1(), cp$, ks&, js&, j&Set d = CreateObject("Scripting.Dictionary")Myr =[b65536].End(xlUp).RowArr = Range("a2:b" & Myr)If Target.Column = 3 ThenFor i = 1 To UBound(Arr)If Arr(i, 1) <> "" Thend(Arr(i, 1)) = ""End IfNextWith Target.Validation.Delete.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, _Operator:=xlBetween, Formula1:=Join(d.keys, ",")End WithTarget.Offset(0, 1) = ""ElseIf Target.Column = 4 And Target.Offset(0, -1) <> "" ThenFor i = 1 To UBound(Arr)If Arr(i, 1) <> "" Thenr = r + 1ReDim Preserve Arr1(1 To r)Arr1(r) = iEnd IfNext iFor i = 1 To rIf Arr(Arr1(i), 1) = Target.Offset(0, -1).Text ThenIf i <> r Thenjs = Arr1(i + 1) - 1Elsejs = Myr - 1End Ifks = Arr1(i)For j = ks To jscp = cp & Arr(j, 2) & ","NextEnd IfNext icp = Left(cp, Len(cp) - 1)With Target.Validation.Delete.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, _Operator:=xlBetween, Formula1:=cpEnd WithTarget = Split(cp, ",")(0)End IfSet d = Nothing End Sub2.8.3 代码详解
代码执行后如图实例8-2所示：
图 实例8-2示例实例 8 文件：点击下载 提取码：lzh7
2.9 实例9 字典取行数，数组重新赋值
2.9.1 问题
要求编写一段代码，求得B列不重复的名字，其相应的A列和D列分别用" "连起来，而相应的E列F列的数值分别相加汇总。
代码执行前如图实例9-1所示。
图 实例9-1示例：
2.9.2 代码
Sub yy() 'by:ZamyiDim d As New Dictionary, RDim k, i&, j&R = Sheet1.UsedRangek = 1For i = 2 To UBound(R)R(i, 2) = Replace(Replace(R(i, 2), "（", "("), "）", ")")If d.Exists(R(i, 2)) ThenR(d(R(i, 2)), 1) = R(d(R(i, 2)), 1) & " " & R(i, 1)R(d(R(i, 2)), 4) = R(d(R(i, 2)), 4) & " " & R(i, 4)R(d(R(i, 2)), 5) = Val(R(d(R(i, 2)), 5)) + R(i, 5)R(d(R(i, 2)), 6) = Val(R(d(R(i, 2)), 6)) + R(i, 6)Elsek = k + 1d(R(i, 2)) = iFor j = 1 To UBound(R, 2)R(k, j) = R(i, j)NextEnd IfNextWith Sheet2.Cells.ClearContents.Cells.Borders.LineStyle = xlNone.[a1:F1].Resize(d.Count + 1) = R.[a1:F1].Resize(d.Count + 1).Borders.LineStyle = 1End WithSet d = Nothing End Sub2.9.3 代码详解
代码执行后如图实例9-2所示：
图 实例9-2示例实例 9 文件：点击下载 提取码：har1
2.10 实例10 先字典求得行后显示整行数据
2.10.1 问题
有3列数据，要求编写一段代码，如果C列名次、A列主排相同时，根据B列次排最大的只保留一行。
解题思路：先对3列数据按主要关键字名次_升序，次要关键字主排_升序，第3关键字次排_降序进行排序，然后运用字典，以”名次|主排” 作为关键字，它所在的行作为关键字的项加入字典，最后根据行引用相对的单元格值。
代码执行前如图实例10-1所示：
图 实例10-1示例2.10.2 代码
Sub pmc()Dim i&, Myr&, ArrDim d, x, rngApplication.ScreenUpdating = FalseSet d = CreateObject("Scripting.Dictionary")Sheet1.ActivateMyr = [a65536].End(xlUp).RowRange("A1:C" & Myr).Sort Key1:=Range("C2"), Order1:=xlAscending, Key2:=Range( _"A2"), Order2:=xlAscending, Key3:=Range("B2"), Order3:=xlDescending, _Header:=xlYesArr = Range("a2:c" & Myr)For i = 1 To UBound(Arr)x = Arr(i, 1) & "|" & Arr(i, 3)If Not d.exists(x) Thend.Add x, i + 1End IfNext[e:g].ClearContents[e2].Resize(d.Count, 1) = Application.Transpose(d.items)For Each rng In [e2].Resize(d.Count, 1)rng.Resize(1, 3) = Cells(rng, 1).Resize(1, 3).ValueNextSet d = NothingApplication.ScreenUpdating = True End Sub2.10.3 代码详解
代码执行后如图实例10-2所示：
图 实例10-2示例实例 10 文件：点击下载 提取码：92ie
2.11 实例11 关键字赋给两列后用Replace方法
2.11.1 问题
有如图实例11-1所示的工资表，要求编写一段代码，运用VBA自动生成1季度的工资表。
解题思路：先把性别和姓名连起来作为关键字求得人员的不重复值，然后通过循环查找关键字获得其各月的工资，最后用Replace方法替换两列关键字区域得到各自的数据。
代码执行前如图实例11-1所示：
图 实例11-1示例2.11.2 代码
Sub yy()Dim d, k, t, i&, j&, Arr, x, r1Set d = CreateObject("Scripting.Dictionary")Arr = [a1].CurrentRegionFor i = 1 To UBound(Arr, 2) Step 3For j = 2 To UBound(Arr)If Arr(j, i) <> "" Thenx = Arr(j, i) & "|" & Arr(j, i + 1)d(x) = ""End IfNextNextk = d.keys[a12:i1000].ClearContents[a13].Resize(d.Count, 2) = Application.Transpose(k)[a12:b12] = Array("性别", "姓名")For i = 3 To UBound(Arr, 2) Step 3Cells(12, 2 + i / 3) = Cells(1, i)NextFor i = 3 To UBound(Arr, 2) Step 3For j = 2 To UBound(Arr)If Arr(j, i) <> "" Thenx = Arr(j, i - 2) & "|" & Arr(j, i - 1)Set r1 = [a13].Resize(d.Count, 1).Find(x, , , 1)Cells(r1.Row, 2 + i / 3) = Arr(j, i)End IfNextNext[a13].Resize(d.Count, 1).Replace "|*", "", xlPart[b13].Resize(d.Count, 1).Replace "*|", "", xlPart End Sub2.11.3 代码详解
代码执行后如图实例11-2所示：
图 实例11-2示例实例 10 文件：点击下载 提取码：x4sb
2.12 实例12 复杂报表汇总
2.12.1 问题的提出 ：
有一日报表，里面有生产型号、生产数量、返修原因、返修数量、报废原因、报废数量，要求编写一段代码，按同型号产品汇总生产数量；得到同型号产品相同返修原因的唯一值；按同型号产品相同返修原因汇总返修数量； 得到同型号产品相同报废原因的唯一值；同型号产品相同报废原因汇总报废数量，并且合并相同内容的单元格。
代码执行前如图实例12-1所示：
图 实例12-1示例2.12.2 代码
Sub bbhz()Dim i&, Myr&, x(1 To 3), Arr, n%, aa, j&, Arr1(), r%, Arr2(), r2%, r3%, Arr3()Dim d(1 To 3) As New dictionary, k(1 To 3), t(1 To 3), js, ks, ii%, jj&, ks1, js1Application.ScreenUpdating = FalseMyr = Sheet1.[a65536].End(xlUp).RowArr = Sheet1.Range("a3:g" & Myr)For i = 1 To UBound(Arr)x(1) = Arr(i, 2)d(1)(x(1)) = d(1)(x(1)) + Arr(i, 3)x(2) = Arr(i, 2) & "|" & Arr(i, 4)d(2)(x(2)) = d(2)(x(2)) + Arr(i, 5)x(3) = Arr(i, 2) & "|" & Arr(i, 4) & "|" & Arr(i, 6)d(3)(x(3)) = d(3)(x(3)) + Arr(i, 7)NextFor i = 1 To 3k(i) = d(i).Keyst(i) = d(i).ItemsNextSheet4.Activate[a3:k1000].ClearContents[a3:k1000].UnMerge[a3:k1000].Borders.LineStyle = xlNone[i3].Resize(d(3).Count, 1) = Application.Transpose(t(3))n = 2For i = 0 To UBound(k(3))aa = Split(k(3)(i), "|")n = n + 1Cells(n, 2) = aa(0)Cells(n, 4) = aa(1)Cells(n, 8) = aa(2)NextFor i = 3 To nFor j = 0 To UBound(k(1))If Cells(i, 2) = k(1)(j) ThenCells(i, 3) = t(1)(j)Cells(i, 10) = Cells(i, 9) / Cells(i, 3)Cells(i, 11) = Cells(i, 10): Exit ForEnd IfNextFor j = 0 To UBound(k(2))If Cells(i, 2) & "|" & Cells(i, 4) = k(2)(j) ThenCells(i, 5) = t(2)(j)Cells(i, 6) = Cells(i, 5) / Cells(i, 3)Cells(i, 7) = Cells(i, 6): Exit ForEnd IfNextNextRange("a3:k" & n).Sort Key1:=Range("b3"), Order1:=xlAscending, Key2:=Range("d3") _, Order2:=xlAscending, Key3:=Range("h3"), Order3:=xlAscending, Header:= _xlGuessFor i = 3 To nIf Cells(i, 2) <> Cells(i - 1, 2) Thenr = r + 1ReDim Preserve Arr1(1 To r)Arr1(r) = iEnd IfNextApplication.DisplayAlerts = FalseFor j = 1 To rr3 = 0: r2 = 0If j <> r Thenjs = Arr1(j + 1) - 1Elsejs = nEnd Ifks = Arr1(j)If js - ks + 1 > 1 ThenCells(ks, 1).Resize(js - ks + 1, 1).MergeCells(ks, 2).Resize(js - ks + 1, 1).MergeCells(ks, 3).Resize(js - ks + 1, 1).MergeEnd IfCells(ks, 1) = jFor ii = ks To jsIf ii = ks Thenr2 = r2 + 1ReDim Preserve Arr2(1 To r2)Arr2(r2) = iiElseIf Cells(ii, 4) <> Cells(ii - 1, 4) Thenr2 = r2 + 1ReDim Preserve Arr2(1 To r2)Arr2(r2) = iiEnd IfNextFor ii = 1 To r2If ii <> r2 Thenjs1 = Arr2(ii + 1) - 1Elsejs1 = jsEnd Ifks1 = Arr2(ii)If js1 - ks1 + 1 > 1 ThenCells(ks1, 4).Resize(js1 - ks1 + 1, 1).MergeFor jj = ks1 To js1If jj <> ks1 ThenCells(ks, 7) = Cells(ks, 7) + Cells(jj, 7)End IfNextCells(ks1, 5).Resize(js1 - ks1 + 1, 1).MergeCells(ks1, 6).Resize(js1 - ks1 + 1, 1).MergeElseIf ii <> 1 ThenCells(ks, 7) = Cells(ks, 7) + Cells(ks1, 7)End IfEnd IfNextCells(ks, 7).Resize(js - ks + 1, 1).MergeFor ii = ks To jsIf ii = ks Thenr3 = r3 + 1ReDim Preserve Arr3(1 To r3)Arr3(r3) = iiElseIf Cells(ii, 8) <> Cells(ii - 1, 8) Thenr3 = r3 + 1ReDim Preserve Arr3(1 To r3)Arr3(r3) = iiEnd IfNextFor ii = 1 To r3If ii <> r3 Thenjs1 = Arr3(ii + 1) - 1Elsejs1 = jsEnd Ifks1 = Arr3(ii)If js1 - ks1 + 1 > 1 ThenCells(ks1, 8).Resize(js1 - ks1 + 1, 1).MergeFor jj = ks1 To js1If jj <> ks1 ThenCells(ks1, 9) = Cells(ks1, 9) + Cells(jj, 9)Cells(ks1, 10) = Cells(ks1, 10) + Cells(jj, 10)End IfCells(ks, 11) = Cells(ks, 11) + Cells(jj, 11)NextCells(ks1, 9).Resize(js1 - ks1 + 1, 1).MergeCells(ks1, 10).Resize(js1 - ks1 + 1, 1).MergeElseIf ii <> 1 ThenCells(ks, 11) = Cells(ks, 11) + Cells(ks1, 11)End IfEnd IfNextCells(ks, 11).Resize(js - ks + 1, 1).MergeNextRange("a3:k" & n).Borders.LineStyle = 1Application.DisplayAlerts = TrueApplication.ScreenUpdating = True End Sub2.12.3 代码详解
代码执行后如图实例12-2所示：
图 实例12-2示例实例 12 文件：点击下载 提取码：z3ob
3. 后语
常见字典用法实例集锦到此告一段落了。字典就象一个二维数组Arr(1 to n,1 to 2)，不过它的第 2 维的最大上界为 2，相当于2列单元格，第1列存放的是关键字，这个关键字是除了数组以外的任何类型；第2列存放的是这个关键字对应的项，它可以是数据的任何类型。
我收集的和接触到有关字典的实例的数量有限，一定会有更好更有代表性的实例没有接触到，希望有心人能提供出来，供大家学习分享。
谢谢大家！
总结
以上是生活随笔为你收集整理的常见字典用法集锦及代码详解的全部内容，希望文章能够帮你解决所遇到的问题。
- 上一篇： html5点击效果文字跳转,JS网页特效
- 下一篇： 三层架构 详解