VBA字典用法小记

十分鄙视那些将蓝桥玄霜大大的成果上传后还要收取下载券的做法，本来想直接上传一份大大的原版，可是百度文档提示已经有重复的文档，没办法，只好自己修改一下，在上传，想无私奉献的大大致敬！！！！！！！！！！

常用语句：

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”。

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") Then

msg = "指定的关键字已经存在。"

Else

msg = "指定的关键字不存在。"

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判断。

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单元格开始的单元格区域中。

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单元格开始的单元格区域中。

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个关键字了。

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属性

返回一个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函数精选合集”。https://www.360docs.net/doc/512336662.html,/thread-387253-1-1.html

CompareMode属性

设置或者返回在Dictionary 对象中进行字符串关键字比较时所使用的比较模式。

https://www.360docs.net/doc/512336662.html,pareMode[ = compare]

参数

object

必选项。总是一个Dictionary 对象的名称。

compare

可选项。如果提供了此项，compare 就是一个代表比较模式的值。可以使用的值是0 (二进制)、1 (文本), 2 (数据库)。

说明

如果试图改变一个已经包含有数据的Dictionary 对象的比较模式，那么将导致一个错误。

常用语句：

Dim d

Set d = CreateObject("Scripting.Dictionary")

https://www.360docs.net/doc/512336662.html,pareMode = vbTextCompare

d.Add "a", "Athens"

d.Add "b", "Belgrade"

d.Add "c", "Cairo"

d.Add " B ", " Baltimore"

代码详解

1、https://www.360docs.net/doc/512336662.html,pareMode = vbTextCompare ：设置字典的比较模式是文本，在这种比较模式下不区分关键字的大小写，即关键字”b”和”B”是一样的。vbTextCompare的值为1，所以上式也可写为https://www.360docs.net/doc/512336662.html,pareMode =1 。如果设置为vbBinaryCompare（值为0），则执行二进制比较，即区分关键字的大小写，此种情况下关键字”b”和”B”被认为是不一样的。

2、d.Add " B ", " Baltimore" ：添加一关键字”B”和对应于它的项”Baltimore”。由于前面已经设置了比较模式为文本模式，不区分关键字的大小写，即关键字”b”和”B”是一样的，此时发生错误添加失败，因为字典中已经存在”b”了，字典中的关键字是唯一的，不能添加重复的关键字。

实例1 普通常见的求不重复值问题

一、问题的提出：

表格中人员有很多是重复的，要求编写一段代码，把重复的人员姓名以及重复的次数求出来，复制到另一个表格中。

如图实例1－1所示。

论坛网址：https://www.360docs.net/doc/512336662.html,/thread-637004-1-1.html

图实例1-1

二、代码：

Sub cfz()

Dim i&, Myr&, Arr

Dim d, k, t

Set d = CreateObject("Scripting.Dictionary")

Myr = Sheet1.[a65536].End(xlUp).Row

Arr = Sheet1.Range("a1:g" & Myr)

For i = 2 To UBound(Arr)

d(Arr(i, 3)) = d(Arr(i, 3)) + 1

k = d.keys

t = d.items

Sheet2.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 Sub

三、代码详解

1、Dim i&, Myr&, Arr ：变量i和Myr声明为长整型变量。也可以写为Dim Myr As Long 。

Long的类型声明字符为(&)。Arr后面没有写明数据类型，默认就是可变型数据类型(Variant)。

3、Myr = Sheet1.[a65536].End(xlUp).Row ：把表1的A列最后一行不为空白的行数赋给变量Myr。这里用了Range对象的End属性，它有4个方向参数，此处的xlUp表示向上，它的值为3，所以也可写成End(3)。xlDown表示向下，它的值为4；xlToLeft表示向左，它的值为1；xlToRight表示向右，它的值为2。

4、Arr = Sheet1.Range("a1:g" & Myr)：把表1的A1到G列最后一行不为空白的单元格区域的值赋给变量Arr。这样Arr就是个二维数组了，用数组替代单元格引用可对执行代码的速度提高很多很多。

5、For i = 2 To UBound(Arr) ：For…Next循环结构，从2开始到数组的最大上界值之间循环。因为数组的第一行是表头。Ubound是VBA函数，返回数组的指定维数的最大可用上界。

6、d(Arr(i, 3)) = d(Arr(i, 3)) + 1 ：Arr(i,3)在本例是姓名列，也就是关键字列，举个例子，假如Arr(i,3)=”张三”，这句代码的意思就是把关键字”张三”加入字典，d(key)等于关键字key对应的项，每出现一次这个关键字，它的项的值就增加1。起到了按关键字累加的作用，也正因为有这个作用，所以可使用字典来进行各种汇总统计。后面要讲的实例会充分的展现这个作用。

7、k=d.keys ：把字典d中存在的所有的关键字赋给变量k。得到的是一个一维数组，下限为0，上限为d.Count-1。Keys是字典的方法，前面已经讲过了。

8、t=d.items ：把字典d中存在的所有的关键字对应的项赋给变量t。得到的也是一个一维数组，下限为0，上限为d.Count-1。Items也是字典的方法，前面也已经讲过了。

9、Sheet2.Activate ：激活表2。

10、[a2].Resize(d.Count, 1) = Application.Transpose(k) ：把字典d中所有的关键字赋给以a2单元格开始的单元格区域中。详细的解释请见前面的keys方法一节。

11、[b2].Resize(d.Count, 1) = Application.Transpose(t) ：把字典d中所有的关键字对应的项赋给以b2单元格开始的单元格区域中。

12、[a1].Resize(1, 2) = Array("姓名", "重复个数") ：Array是一个VBA函数，返回一个下界为0的一维数组。一维数组可以看作是水平排列的，所以赋值给水平的单元格区域不需要用转置函数了。这里作为表头一次性输入。

13、Set d = Nothing ：释放字典内存。

代码执行后如图实例1-2所示。

图实例1-2

实例2 求多表的不重复值问题

一、问题的提出：

一工作簿里面有3张工作表上，每张表格的A列都是姓名列，所有这些姓名中有些是重复的，要求编写一段代码，在另一个工作表上显示不重复的姓名。

如图实例2－1所示。

图实例2-1 这个问题也很适合用字典来解决。代码如下：

二、代码：

Sub bcfz()

Dim i&, Myr&, Arr

Dim d, k, t, Sht As Worksheet

Set d = CreateObject("Scripting.Dictionary")

For Each Sht In Sheets

If https://www.360docs.net/doc/512336662.html, <> "Sheet4" Then

Myr = Sht.[a65536].End(xlUp).Row

Arr = Sht.Range("a2:a" & Myr)

For i = 1 To UBound(Arr)

d(Arr(i, 1)) = ""

End If

k = d.keys

Sheet4.[a3].Resize(d.Count, 1) = Application.Transpose(k) Set d = Nothing

End Sub

三、代码详解

1、For Each Sht In Sheets ：For Each…Next循环结构，这种形式是VBA特有的，用于对对象的循环非常适用。意思是在所有的工作表中依次循环。

2、If https://www.360docs.net/doc/512336662.html, <> "Sheet4" Then ：如果这个工作表的名字不等于”Sheet4”时执行下面的代码。

3、Myr = Sht.[a65536].End(xlUp).Row ：求得这个工作表A列有数据的最后一行的行数，把它赋给变量Myr。这里用了长整型数据类型(Long)，数据范围最大可到2,147,483,647，是为了避免数据很多的时候会超出整型数据类型(Integer)而出错，因为整型数据类型数据范围最大只到32,767。

4、Arr = Sht.Range("a2:a" & Myr) ：把A列数据赋给数组Arr。

5、For i = 1 To UBound(Arr) ：For…Next循环结构，从1开始到数组的最大上限值之间循环。Ubound是VBA函数，返回数组的指定维数的最大值。

6、d(Arr(i, 1)) = “”：这句代码的意思就是把关键字Arr(i,1)加入字典，关键字对应的项为空，相当于字典中的这个关键字没有解释。和d.Add Arr(i,1), ""的效果相同，只是代码更简洁一些。

7、k=d.keys ：把字典d中存在的所有的关键字赋给变量k。得到的是一个一维数组，下限为0，上限为d.Count-1。Keys是字典的方法，前面已经讲过了。

8、Sheet4.[a3] .Resize(d.Count, 1) = Application.Transpose(k) ：把字典d中所有的关键字赋给表4以a3单元格开始的单元格区域中。

代码执行后如图实例2-2所示。

图实例2-2

实例3 A列中显示1 ~ 1000中被6除余1和余5 的数字

一、问题的提出：

有1、2、3…1000一千个数字，要求编写一段代码，在工作表的A列显示这些数被6除余1和余5的数字。

二、代码：

Sub 余1余5() …by:狼版主

Dim dic As Object, i As Long, arr

Set dic = CreateObject("Scripting.Dictionary")

For i = 1 To 1000

dic.Add i & IIf(Abs(i Mod 6 - 3) = 2, "@", ""), ""

arr = WorksheetFunction.Transpose(Filter(dic.keys, "@"))

[a1].Resize(UBound(arr), 1) = arr

[a:a].Replace "@", ""

Set dic = Nothing

End Sub

三、代码详解

1、Dim dic As Object, i As Long, arr ：也可把字典变量dic声明为对象(Object)，i As Long 是规范的写法，也可写成i& 。

2、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，关键字相对应的项都为空。

3、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。

呵呵，狼版主的代码是短了，我的解释却太长了。

4、[a1].Resize(UBound(arr), 1) = arr：把数组Arr赋给[a1]单元格开始的区域中。

5、[a:a].Replace "@", ""：把A列中的所有的@都替换为空白，只剩下数字了。

代码详解的4代码执行后，如图实例3-1所示。

图实例3-1 示例

代码全部执行后如图实例3-2所示。

图实例3-2 示例

实例4 拆分数据不重复

一、问题的提出：

有一列各种手机品牌型号的数据，要求编写一段代码，按照品牌划分成没有重复数据的三大类。

二、代码：

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

三、代码详解

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 示例

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

四、山菊花版主的代码：

Sub 拆分()

Dim pp1$, pp2$, nRow%, ds, Brr(), s(1 To 3) As Integer

Set ds = CreateObject("scripting.dictionary")

pp1 = Join(WorksheetFunction.Transpose(Range(Range("g2"), Range("g1").End(xlDow n))), ",")

pp2 = Join(WorksheetFunction.Transpose(Range(Range("h2"), Range("h1").End(xlDow n))), ",")

nRow = Range("a1").End(xlDown).Row

Arr = Range("a1:a" & nRow)

ReDim Brr(1 To nRow, 1 To 3)

For i = 2 To nRow

If Not ds.Exists(Arr(i, 1)) Then

ds(Arr(i, 1)) = ""

If pp1 Like "*" & Left(Arr(i, 1), 2) & "*" Then

s(1) = s(1) + 1

Brr(s(1), 1) = Arr(i, 1)

ElseIf pp2 Like "*" & Left(Arr(i, 1), 2) & "*" Then

s(2) = s(2) + 1

Brr(s(2), 2) = Arr(i, 1)

Else

s(3) = s(3) + 1

Brr(s(3), 3) = Arr(i, 1)

End If

Range("c2:e" & nRow) = Brr

End Sub

五、代码详解

1、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一句同上句一样，得到另一个字符串。

2、nRow = Range("a1").End(xlDown).Row ：把A列最后一行不为空白的行数赋给整

型变量nRow。

3、Arr = Range("a1:a" & nRow) ：把A列A1开始的有数据的单元格区域赋给变量Arr。

4、ReDim Brr(1 To nRow, 1 To 3) ：用于为动态数组变量Brr重新分配存储空间。第一维

的下界从1到上界nRow，第二维从1到3。

5、For i = 2 To nRow ：从2到nRow逐一循环。

6、If Not ds.Exists(Arr(i, 1)) Then：如果字典ds中不存在关键字Arr(i, 1)

7、ds(Arr(i, 1)) = "" ：把Arr(i, 1)作为关键字加入字典ds。

8、If pp1 Like "*" & Left(Arr(i, 1), 2) & "*" Then：这里山版主用了比较运算符Like来比较

pp1和取自Arr(i, 1)左边两个字符，再在前后加任意字符组成的字符串，如果满足条件为真，那么执行下面的语句。

9、s(1) = s(1) + 1：数组s的第一个元素+1以后赋给数组s的第一个元素。

10、Brr(s(1), 1) = Arr(i, 1)：把这个关键字赋给第2维为1的另一个数组Brr，也就是我

们要求的贸易机类。pp1字符串里都是贸易机类的品牌。

11、ElseIf pp2 Like "*" & Left(Arr(i, 1), 2) & "*" Then：同样，如果满足国产品牌类这个条件，

那么执行下面的代码。

12、s(2) = s(2) + 1：数组s的第二个元素+1以后赋给数组s的第二个元素。

13、Brr(s(2), 2) = Arr(i, 1)：把这个关键字赋给第2维为2的另一个数组Brr，也就是我

们要求的国产品牌类。pp2字符串里都是国产品牌类的品牌。

14、s(3) = s(3) + 1：前如果条件都不满足时，数组s的第三个元素+1以后赋给数组s

的第三个元素。

15、Brr(s(3), 3) = Arr(i, 1)：把这个关键字赋给第3维为1的另一个数组Brr，也就是我

们要求的其它品牌类。

16、Range("c2:e" & nRow) = Brr：把数组Brr赋给[c2]单元格开始的区域中。

实例5 前期绑定的字典实例

一、问题的提出：

有多列多行数据，其中有重复的行，要求编写一段代码，求得不重复的行数据。

如图实例5-1所示。

图实例5-1 示例

二、代码：

Sub 保留原数据() …by:ldy888

…前期绑定，需先引用c:\windows\system32\scrrun.dll

Dim d As New Dictionary,t

For i = 2 To 5

Set d(Cells(i, 1) & "") = Range(Cells(i, 1), Cells(i, 4))

t=d.items

[A11].Resize(d.Count, 4) = Application.Transpose(Application.Transpose(t))

End Sub

三、代码详解

1、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")，称为”后期绑定”。不需要先引用脚本运行时库。

2、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来代替。

3、t=d.items ：把字典d中存在的所有的关键字对应的项赋给变量t。得到的是一个

一维数组，下限为0，上限为d.Count-1。

4、[A11].Resize(d.Count, 4) = Application.Transpose(Application.Transpose(t)) ：这句用

了两次工作表转置函数Transpose之后赋给A11单元格开始的区域中。

代码执行后如图实例5-2所示。

图实例5-2示例

实例6 多条件复杂汇总

一、问题的提出：

有一个表格，需要对其中多个条件相同的数量进行合并汇总，并且要有汇总的明细数据，要求编写一段代码，实现这样的合并同类项的要求。

二、代码：

Sub kf2() …by:oobird

Dim d As Object, a, b, j%, w!

Dim ss$, n%, x

https://www.360docs.net/doc/512336662.html,edRange.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) Then

n = n + 1

d.Add ss, n

b(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)

Else

b(d(ss), 7) = b(d(ss), 7) & "+" & a(i, 9)

End If

For i = 1 To d.Count

x = Split(b(i, 7), "+")

For j = 0 To UBound(x)

w = w + x(j)

Next j

b(i, 8) = b(i, 5) * b(i, 6) * w / 100: w = 0

[b4].Resize(n, 8) = b

End Sub

三、代码详解

1、Dim d As Object, a, b, j%, w!：Dim语句中的j% 等同于Dim j As Integer。w! 等同于Dim w As Single。类似的还有ss$ 等同于Dim ss As String。还有双精度数据类型Double 的类型声明字符为#、货币数据类型Currency的类型声明字符为@。

2、https://www.360docs.net/doc/512336662.html,edRange.Offset(3, 0) = "" ：Offset是Range对象的属性，Offset(3, 0)的第一个

参数是行数；第二个参数是列数，意思是往下偏移3行，列不变。Me是活动工作表，相当于Activesheet; UsedRange为已经使用的单元格区域。本句可解释为：清空第3行

以下的单元格。

3、a = Sheet1.Range(Sheet1.[a4], Sheet1.[i65536].End(xlUp)) ：把原始数据所在的表1自A4以下的I列最后的非空单元格区域的值赋给变量a。

4、Set d = CreateObject("scripting.dictionary") ：创建字典对象d。

5、ReDim b(1 To UBound(a), 1 To 8) ：根据数组a的大小重新声明数组b。

6、For i = 1 To UBound(a) ：在1 和数组a第一维的上界值之间逐一循环。

7、ss = a(i, 1) & a(i, 2) & a(i, 4) & a(i, 5) & a(i, 6) & a(i, 8) ：把多个条件比例、位置、项目名称、大系统编号、小系统编号和相同楼层数用连接符号&连成一个字符串，然后赋给变量ss。

8、If Not d.Exists(ss) Then ：If…Then结构利用了字典的Exists方法和Not来判断：如果字典d里面不存在ss表示的关键字，那么执行下面的语句。

9、n = n + 1 ：把变量n增加1以后仍然赋给n。

10、d.Add ss, n：把ss的值作为关键字，n的值作为对应的项一起加入字典d中。n 的值实际是关键字的位置次序，如n=1时是第一个关键字；n=2时是第二个关键字。

11、b(n, 1) = a(i, 2): b(n, 2) = a(i, 5): b(n, 3) = a(i, 6): b(n, 4) = a(i, 4) ：为了使代码看起来简短一些，可以用冒号”:”把多个语句连成一行。4个语句分别给数组b的各个元素赋以对应的值。

12、b(n, 5) = a(i, 1): b(n, 6) = a(i, 8): b(n, 7) = a(i, 9) ：与上述的11条相同。

13、否则执行这句：b(d(ss), 7) = b(d(ss), 7) & "+" & a(i, 9) ：d(ss)等于关键字对应的项，在本例里等于对应的n的值。本句是把图纸长度a(i, 9)用"+"连起来赋给数组b，这样就得到了长度明细一栏数据。

14、For i = 1 To d.Count ：在字典关键字数目中逐一循环。

15、x = Split(b(i, 7), "+")：运用VBA函数Split把b(i, 7)（长度明细）按照"+"分割，返回一个下标从零开始的一维数组x。如果要详细了解Split函数的，可参见我的另一篇文章“常用VBA函数精选合集”。https://www.360docs.net/doc/512336662.html,/thread-387253-1-1.html

16、For j = 0 To UBound(x) ：在上面的x数组之间逐一循环。

17、w = w + x(j) ：把变量w加x(j)数组的一个元素以后仍然赋给w。实际得到x数组的累加值。

18、b(i, 8) = b(i, 5) * b(i, 6) * w / 100: w = 0 ：w求出后经过按要求计算得到的值赋给数组b的第8列元素。（数量列）另一句把变量w置0。避免在新一次的循环中误加进去。

19、[b4].Resize(n, 8) = b ：最后把数组b赋给B4开始的单元格区域。

代码执行后如图实例6-1所示。