VBA字典用法小记 - 图文

VBA字典用法小记

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

常用语句：

Dim d

Set d = CreateObject(\d.Add \ d.Add \d.Add \代码详解

1、Dim d ：创建变量，也称为声明变量。变量d声明为可变型数据类型(Variant)，d后面没有写数据类型，默认就是可变型数据类型(Variant)。也有写成Dim d As Object的，声明为对象。

2、Set d = CreateObject(\：创建字典对象，并把字典对象赋给变量d。这是最常用的一句代码。所谓的“后期绑定”。用了这句代码就不用先引用c:\\windows\\system32\\scrrun.dll了。

3、d.Add \：添加一关键字”a”和对应于它的项”Athens”。 4、d.Add \“Belgrade”：添加一关键字”b”和对应于它的项”Belgrade”。 5、d.Add \“Cairo”：添加一关键字”c”和对应于它的项”Cairo”。

Exists方法

如果 Dictionary 对象中存在所指定的关键字则返回 true，否则返回 false。 object.Exists(key) 参数 object

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

必选项。需要在 Dictionary 对象中搜索的 key 值。

常用语句： Dim d, msg$

Set d = CreateObject(\ d.Add \ d.Add \

d.Add \ If d.Exists(\

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

msg = \指定的关键字不存在。\ End If 代码详解

1、Dim d, msg$ ：声明变量，d见前例；msg$ 声明为字符串数据类型(String)，一般写法为Dim msg As String。String 的类型声明字符为美元号 ($)。

2、If d.Exists(\：如果字典中存在关键字”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(\ d.Add \ d.Add \ d.Add \ 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(\ d.Add \ d.Add \ d.Add \ 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(\ d.Add \ d.Add \ d.Add \ ……

d.Remove(“b”) 代码详解

1、d.Remove(“b”)：清除字典中”b”关键字和与它对应的项。清除之后,现在字典里只有2个关键字了。

RemoveAll方法

RemoveAll 方法从一个 Dictionary 对象中清除所有的关键字，项目对。 object.RemoveAll( )

其中 object 总是一个 Dictionary 对象的名称。 常用语句： Dim d

Set d = CreateObject(\ d.Add \ d.Add \ d.Add \ ……

d.RemoveAll 代码详解

1、d.RemoveAll：清除字典中所有的数据。也就是清空这字典，然后可以添加新的关键字和项，形成一本新字典。

字典对象的属性有4个：Count属性、Key属性、Item属性、CompareMode属性。 Count属性

返回一个Dictionary 对象中的项目数。只读属性。 object.Count

其中 object一个字典对象的名称。 常用语句： Dim d,n%

Set d = CreateObject(\ d.Add \ d.Add \ d.Add \ 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(\ d.Add \ d.Add \ d.Add \ d.Key(\ 代码详解

1、d.Key(\：用新的关键字”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(\ d.Add \ d.Add \ d.Add \ MsgBox d.Item(\ 代码详解

1、d.Item(\：获取指定的关键字”c”对应的项。 2、MsgBox ：是一个VBA函数，用消息框显示。如果要详细了解MsgBox函数的，可参见我的另一篇文章“常用VBA函数精选合集”。http://club.excelhome.net/thread-387253-1-1.html

CompareMode属性

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

object.CompareMode[ = compare] 参数 object

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

说明

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

常用语句： Dim d

Set d = CreateObject(\ d.CompareMode = vbTextCompare d.Add \ d.Add \ d.Add \

d.Add \代码详解

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

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

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

一、问题的提出：

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

如图实例1－1所示。

论坛网址：http://club.excelhome.net/thread-637004-1-1.html

图 实例1-1

二、代码： Sub cfz()

Dim i&, Myr&, Arr Dim d, k, t

Set d = CreateObject(\Myr = Sheet1.[a65536].End(xlUp).Row Arr = Sheet1.Range(\& Myr) For i = 2 To UBound(Arr) d(Arr(i, 3)) = d(Arr(i, 3)) + 1 Next 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)。

2、Set d = CreateObject(\：创建字典对象，并把字典对象赋给变量d。这是最常用的一句代码。所谓的“后期绑定”。用了这句代码就不用先引用c:\\windows\\system32\\scrrun.dll了。

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(\：把表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(\For Each Sht In Sheets

If Sht.Name <> \Then Myr = Sht.[a65536].End(xlUp).Row Arr = Sht.Range(\& Myr) For i = 1 To UBound(Arr) d(Arr(i, 1)) = \ Next End If Next 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 Sht.Name <> \：如果这个工作表的名字不等于”Sheet4”时执行下面的代码。

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

4、Arr = Sht.Range(\ ：把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(\For i = 1 To 1000

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

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(\Set d1 = CreateObject(\Set d2 = CreateObject(\Myr = [a65536].End(xlUp).Row Arr = Range(\& Myr) Range(\& Myr).ClearContents

my = Array(\\诺基亚\\三星\\索爱\

gc = Array(\\联想\\天语\\金立\\步步高\\波导\\\酷派\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(\+ 1, 1) = Application.Transpose(d.keys) Range(\+ 1, 1) = Application.Transpose(d1.keys) Range(\+ 1, 1) = Application.Transpose(d2.keys) End Sub

三、代码详解

1、Set d2 = CreateObject(\ ：针对三个不同的种类，创建d、d1、d2三个字典对象。

2、Myr = [a65536].End(xlUp).Row ：把A列最后一行不为空白的行数赋给变量Myr。 3、Arr = Range(\ ：把A2开始的有数据的单元格区域赋给变量Arr。 4、Range(\：把C2到E列单元格区域清空。

5、my = Array(\诺基亚\三星\索爱\ ：VBA函数Array返回一个一维数组，默认下界为0。把Array函数返回的数组赋给变量my(贸易两汉字的首字母)。

6、gc = Array(\联想\天语\金立\步步高\波导\酷派\ ：把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循环，一是为了减少循环的次数，比如\找到的话，后面3个就不需要找了；二是为了跳过两个小循环之后的其它品牌加入第3个字典的d2(Arr(x, 1)) = \语句。 12、For j循环与上面相同，为了判断得到国产机类的字典d1。 13、d2(Arr(x, 1)) = \ ：如果上述两个小循环都不满足，那么就加入其它品牌类字典里。 14、Range(\ ：最后的3句分别把字典的关键字数组转置后赋给相应的单元格区域。

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

图 实例4-1 示例

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

四、山菊花版主的代码： Sub 拆分()

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

pp1 = Join(WorksheetFunction.Transpose(Range(Range(\Range(\n))), \

pp2 = Join(WorksheetFunction.Transpose(Range(Range(\Range(\n))), \

nRow = Range(\

Arr = Range(\& 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 End If Next

Range(\& nRow) = Brr End Sub

五、代码详解

1、pp1 = Join(WorksheetFunction.Transpose(Range(Range(\ Range(\ ：

这句代码用了两个VBA函数Join 和Transpose ，Range(\从G1单元格往下直到最下面的单元格，遇到空白格就停止。因为本例的G14、G15单元格有 另外的数据存在，如果还是用Range(\，那么就会把不需要的数据带进去，造成结果出错。Transpose 转置函数，前面已经介绍过了。Join函数是通过连接某个数组中的多个子字符串而创建的一个字符串，本句代码执行后得到pp1=\诺基亚, 三星, 索爱\。

pp2一句同上句一样，得到另一个字符串。

2、nRow = Range(\ ：把A列最后一行不为空白的行数赋给整型变量nRow。 3、Arr = Range(\：把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 \ ：这里山版主用了比较运算符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 \ ：同样，如果满足国产品牌类这个条件，那么执行下面的代码。

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(\ ：把数组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))

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

2、Set d(Cells(i, 1) & \：把单元格对象加入字典，它对应的项是同一行的单元格区域。注意，这里用了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

Me.UsedRange.Offset(3, 0) = \

a = Sheet1.Range(Sheet1.[a4], Sheet1.[i65536].End(xlUp)) Set d = CreateObject(\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 Next

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 Next

[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、Me.UsedRange.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(\：创建字典对象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) & \：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函数精选合集”。http://club.excelhome.net/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所示。

图 实例6-1示例

实例7 字典法排序

一、问题的提出：

A列B列是按顺序排列的全部股票代码和股票名称，C列D列和E列F列是另外按条件筛选出来的无序的数据， 要求编写一段代码，将它们排列到与A列相同的股票行里面。

代码执行前如图实例7-1所示。

图 实例7-1示例

二、代码：

Private Sub CommandButton1_Click() ?by:oobird Dim d As Object, rng, i%, j%, arr Set d = CreateObject(\rng = Range(\& [a65536].End(xlUp).Row) ReDim arr(1 To UBound(rng), 1 To 4) For i = 1 To UBound(rng)

d(CStr(rng(i, 1))) = i Next i

For j = 3 To 5 Step 2

For i = 1 To Cells(65536, j).End(xlUp).Row - 2

If d(CStr(rng(i, j))) <> \Then

arr(d(CStr(rng(i, j))), j - 2) = rng(i, j) arr(d(CStr(rng(i, j))), j - 1) = rng(i, j + 1) End If Next i Next j

[c3].Resize(UBound(rng), 4) = arr End Sub

三、代码详解

1、Dim d As Object, rng, i%, j%, arr ：声明各个变量。

2、Set d = CreateObject(\：创建字典对象d。

3、rng = Range(\ ：把A列到F列的单元格区域的值赋给变量rng。

4、ReDim arr(1 To UBound(rng), 1 To 4) ：根据数组rng的大小重新声明动态数组变量的大小，这里是按最大数量来声明，可避免因声明得小了而导致代码出错。 5、For i = 1 To UBound(rng) ：在rng数组中逐一循环。

6、d(CStr(rng(i, 1))) = i ：把A列的股票代码的值用VBA转换函数CStr转换成字符串以后作为关键字，因为如果不作处理有时候遇到00开始的数据，可能会失去前面的0。股票代码在数组中的行位置i作为关键字对应的项，一起加入字典d。

7、For j = 3 To 5 Step 2 ：前面的循环得到了整个字典，下面这两个循环用来与字典中的关键字比对而重新排位。Step 2是循环的步长，j=3执行以后，j=3+2=5，从而跳过j=4了。呵呵，这是For…Next循环结构的基础知识，说多了。

8、For i = 1 To Cells(65536, j).End(xlUp).Row – 2 ：因为C列和E列的最后一个非空单元格的位置不一样，所以用了Cells(65536, j).End(xlUp).Row在循环中分别得到这两列的最后一个非空单元格的行数，由于数组rng是从第3行开始的，为了与下面引用的rng数组对应，所以需要减去2。全句是在C列和E列中逐一循环。

9、If d(CStr(rng(i, j))) <> \ ：rng(i, j)是C列或者E列的股票代码，本句是如果这个股票代码关键字对应的项不等于空的时候，执行下面的代码。

10、arr(d(CStr(rng(i, j))), j - 2) = rng(i, j) ：d(CStr(rng(i, j)))=i见上述6的解释，表示数组arr的第1维，相当于行；j-2是随着j=3的时候，j-2=1；j=5的时候j-2=3，相当于数组

列的参数。把相应的股票代码赋给相同股票代码的第1列或者是第3列。

11、arr(d(CStr(rng(i, j))), j - 1) = rng(i, j + 1) ：把相应的股票名称赋给相同股票代码的第2列或者是第4列。

12、[c3].Resize(UBound(rng), 4) = arr ：把数组arr赋给C3开始的单元格区域。

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

图 实例7-2示例

实例8 2级动态数据有效性问题

一、问题的提出：

A列是源名称，中间有空格，B列为各个源名称对应的数目不同的代号，C列是目标名称来源于源名称，要求在C列设置不重复的、没有空格的数据有效性供选择；同时D列目标代号，要求随着C列选择的目标名称的不同，提供对应的代号供选择，是为第2级数据有效性。

代码执行前如图实例8-1所示。

图 实例8-1示例

二、代码：

Private Sub Worksheet_SelectionChange(ByVal Target As Range) If Target.Count > 1 Then Exit Sub

If Target.Column <> 4 And Target.Column <> 3 Then Exit Sub Dim d, i&, Myr&, Arr, r%, Arr1(), cp$, ks&, js&, j& Set d = CreateObject(\Myr =[b65536].End(xlUp).Row Arr = Range(\& Myr) If Target.Column = 3 Then For i = 1 To UBound(Arr) If Arr(i, 1) <> \Then d(Arr(i, 1)) = \ End If Next

With Target.Validation .Delete

.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, _ Operator:=xlBetween, Formula1:=Join(d.keys, \ End With

Target.Offset(0, 1) = \

ElseIf Target.Column = 4 And Target.Offset(0, -1) <> \Then For i = 1 To UBound(Arr) If Arr(i, 1) <> \Then

r = r + 1

ReDim Preserve Arr1(1 To r) Arr1(r) = i End If Next i For i = 1 To r

If Arr(Arr1(i), 1) = Target.Offset(0, -1).Text Then If i <> r Then

js = Arr1(i + 1) - 1 Else

js = Myr - 1 End If ks = Arr1(i) For j = ks To js

cp = cp & Arr(j, 2) & \ Next End If Next i

cp = Left(cp, Len(cp) - 1) With Target.Validation .Delete

.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, _ Operator:=xlBetween, Formula1:=cp End With

Target = Split(cp, \End If

Set d = Nothing End Sub

三、代码详解

1、Private Sub Worksheet_SelectionChange(ByVal Target As Range) ：本例用的是工作表选择变化事件，只要鼠标点击单元格都会激活这个事件。Private 可译为私有的，限制了这段代码只能在指定的工作表里有效。参数Target声明为单元格区域对象，有了关键字ByVal，说明可以按值传递参数。

2、If Target.Count > 1 Then Exit Sub ：由于是鼠标点击单元格都会激活这个事件,所以最好要作一些限制，使得你能避免点击了不需要激活事件的地方而激活本事件产生错误。本句是如果目标单元格的数目大于1就退出本过程。这样当你点选了多个单元格的时候，过程运行了这句代码就会结束过程了。

3、If Target.Column <> 4 And Target.Column <> 3 Then Exit Sub ：再加一个限制，如果目标单元格的列不是3列（C列）也不是4列（D列）的话就退出过程。

4、接着的四句代码分别是声明变量、创建字典对象、B列最后一个非空单元格的行数以及把单元格区域的值赋给数组变量等等与前面的实例相同。请注意这里选择了B列求最后一个非空单元格的行数，是因为A列各数据之间有空格，如果选择A列，就会

图 实例10-1示例

二、代码： Sub pmc()

Dim i&, Myr&, Arr Dim d, x, rng

Application.ScreenUpdating = False Set d = CreateObject(\Sheet1.Activate

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

Range(\& Myr).Sort Key1:=Range(\Order1:=xlAscending, Key2:=Range( _ \Order2:=xlAscending, Key3:=Range(\Order3:=xlDescending, _ Header:=xlYes Arr = Range(\& Myr) For i = 1 To UBound(Arr)

x = Arr(i, 1) & \& Arr(i, 3) If Not d.exists(x) Then d.Add x, i + 1 End If Next

[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).Value Next

Set d = Nothing

Application.ScreenUpdating = True End Sub

三、代码详解

1、Application.ScreenUpdating = False ：关闭屏幕更新。关闭屏幕更新可加快宏的执行速度。请记住当宏结束执行时，将 ScreenUpdating 属性设回到 True。

2、Range(\

Order2:=xlAscending, Key3:=Range(\

Header:=xlYes ：对ABC三列进行排序。主要关键字Key1名次_升序，次要关键字Key2

主排_升序，第3关键字Key3次排_降序。

3、Arr = Range(\：把ABC列数据赋给变量Arr。

4、For i = 1 To UBound(Arr) ：i从1到数组Arr的最大上界逐一循环。 5、x = Arr(i, 1) & \：把主排和”|”和名次连起来赋给变量x。

6、If Not d.exists(x) Then ：如果字典中不存在x这个关键字，那么执行下面的代码。 7、d.Add x, i + 1 ：把x作为关键字和这个关键字的具体的行作为对应的项加入字典。因为数组Arr是从A2开始的，所以i与数据的实际行相差1，i+1就是数据的实际行。 8、[e:g].ClearContents ：清空E~G列。

9、[e2].Resize(d.Count, 1) = Application.Transpose(d.items) ：把字典所有的项转置以后赋给E2单元格开始的区域。

10、For Each rng In [e2].Resize(d.Count, 1) ：For- Each-Next控制结构是VBA中功能最

强的循环控制结构，利用这个结构可对集合中的所有对象或者数组中的所有元素进行同一操作。它的一个优点在于你不必操心循环应该执行多少次，它循环的次数恰好就是数组中元素的个数（或者集合中对象的个数），因此对于处理多维数组特别是处理对象时最有效率。本句意思是在E2单元格开始的单元格区域中逐一循环。

11、rng.Resize(1, 3) = Cells(rng, 1).Resize(1, 3).Value ：把关键字所在行的3个单元格的值赋给rng开始的3个单元格。在Cells(rng, 1)中作为参数的rng＝rng.Valur，而rng.Resize(1, 3)处的rng是一个单元格对象。

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

图 实例10-2示例

实例11 关键字赋给两列后用Replace方法

一、问题的提出：

有如图实例11-1所示的工资表，要求编写一段代码，运用VBA自动生成1季度的工资表。

解题思路：先把性别和姓名连起来作为关键字求得人员的不重复值，然后通过循环查找关键字获得其各月的工资，最后用Replace方法替换两列关键字区域得到各自的数据。 代码执行前如图实例11-1所示。

图 实例11-1示例

二、代码： Sub yy()

Dim d, k, t, i&, j&, Arr, x, r1

Set d = CreateObject(\Arr = [a1].CurrentRegion

For i = 1 To UBound(Arr, 2) Step 3 For j = 2 To UBound(Arr) If Arr(j, i) <> \Then

x = Arr(j, i) & \& Arr(j, i + 1) d(x) = \ End If Next Next k = d.keys

[a12:i1000].ClearContents

[a13].Resize(d.Count, 2) = Application.Transpose(k) [a12:b12] = Array(\性别\\姓名\For i = 3 To UBound(Arr, 2) Step 3 Cells(12, 2 + i / 3) = Cells(1, i) Next

For i = 3 To UBound(Arr, 2) Step 3 For j = 2 To UBound(Arr) If Arr(j, i) <> \Then

x = 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 If Next Next

[a13].Resize(d.Count, 1).Replace \\xlPart [b13].Resize(d.Count, 1).Replace \\xlPart End Sub

三、代码详解

1、Arr = [a1].CurrentRegion ：把含有A1单元格的当前单元格区域的值赋给变量Arr。CurrentRegion是Range对象的属性，当前区域指以任意空白行及空白列的组合为边界的区域。如本题A11单元格有数据，但是因为第10行是空白行，所以没有包含在A1的当前区域里面。

2、For i = 1 To UBound(Arr, 2) Step 3 ：For-Next控制结构，从1 到数组第2维的最大上界每隔3进行一次循环，Step 3是循环的步长，第一次循环时i=1；第2次循环时i=1+3=4，第3次时i=4+3=7。

3、For j = 2 To UBound(Arr) ：从第2行开始循环。没有Step时默认Step为1。

4、If Arr(j, i) <> \ ：If-Then-Else控制结构可根据测试条件的结果改变程序执行的流程。本句测试条件是Arr(j, i) <> \，判断性别是否为空白，如果不为空白则执行下面的语句，否则，执行Else下面的语句。

5、x = Arr(j, i) & \：把性别和姓名中间加“|”连起来赋给变量x。

6、d(x) = \ ：把x的值作为关键字加入字典d。比如把”男|赵” 加入字典d。这两个循环把每个月的所有的人员都加入了字典d，字典中的人员是没有重复的。 7、k = d.keys ：把字典d所有的关键字赋给变量k。

8、[a12:i1000].ClearContents ：清空A12：I1000单元格区域。

9、[a13].Resize(d.Count, 2) = Application.Transpose(k) ：把变量k转置之后赋给A13开始的单元格区域。Resize是Range对象的属性，调整指定区域的大小，其第1个参数是行的大小，d.Count表示字典关键字的数量，如果有10个关键字，那么就是10行；其第2个参数是列的大小，一般是赋给1列的，本例关键字由两个数据合并而成，所以先赋给2列，后面再处理。

10、[a12:b12] = Array(\性别\姓名\ ：Array是一个VBA函数，返回一个下界为0的一维数组。一维数组可以看作是水平排列的，这里作为表头一次性输入。 11、For i = 3 To UBound(Arr, 2) Step 3 ：从第3列开始循环，步长为3。 12、Cells(12, 2 + i / 3) = Cells(1, i) ：把“1月工资“、“2月工资“等输入到相应表头的位置。

13、Set r1 = [a13].Resize(d.Count, 1).Find(x, , , 1) ：在A13单元格开始的区域中查找字符串变量x，Find方法是Range对象的一个方法，其中第4个参数值为1，其常量为xlWhole，表示精确查找，另一个常量为xlPart，它的值＝2。Find方法返回的是Range对象，所以前面要用Set语句来引用对象。

14、Cells(r1.Row, 2 + i / 3) = Arr(j, i) ：把关键字对应的工资赋给相应的单元格里。

15、[a13].Resize(d.Count, 1).Replace \：Replace方法是Range对象的一个方法，其第1个参数是要查找的字符串，这里\是竖线及后面所有的字符串；其第2个参数是替换字符串，这里替换为空；其第3个参数是精确查找还是模糊查找，xlPart常量的值＝2，可以用2代替它。本句是把姓名替换掉，只留下性别；下一句把B列中的性别替换掉，只留下姓名。 代码执行后如图实例11-2所示。

图 实例11-2示例

实例12 复杂报表汇总

一、问题的提出 ：

有一日报表，里面有生产型号、生产数量、返修原因、返修数量、报废原因、报废数量，要求编写一段代码，按同型号产品汇总生产数量；得到同型号产品相同返修原因的唯一值；按同型号产品相同返修原因汇总返修数量； 得到同型号产品相同报废原因的唯一值；同型号产品相同报废原因汇总报废数量，并且合并相同内容的单元格。

代码执行前如图实例12-1所示。

图 实例12-1示例

二、代码： 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, js1 Application.ScreenUpdating = False Myr = Sheet1.[a65536].End(xlUp).Row Arr = Sheet1.Range(\& 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) Next

For i = 1 To 3 k(i) = d(i).Keys t(i) = d(i).Items Next

Sheet4.Activate [a3:k1000].ClearContents [a3:k1000].UnMerge

[a3:k1000].Borders.LineStyle = xlNone

[i3].Resize(d(3).Count, 1) = Application.Transpose(t(3)) n = 2

For i = 0 To UBound(k(3)) aa = Split(k(3)(i), \ n = n + 1 Cells(n, 2) = aa(0) Cells(n, 4) = aa(1) Cells(n, 8) = aa(2) Next

For i = 3 To n

For j = 0 To UBound(k(1)) If Cells(i, 2) = k(1)(j) Then Cells(i, 3) = t(1)(j)

Cells(i, 10) = Cells(i, 9) / Cells(i, 3) Cells(i, 11) = Cells(i, 10): Exit For End If Next

For j = 0 To UBound(k(2))

If Cells(i, 2) & \& Cells(i, 4) = k(2)(j) Then Cells(i, 5) = t(2)(j)

Cells(i, 6) = Cells(i, 5) / Cells(i, 3) Cells(i, 7) = Cells(i, 6): Exit For End If Next Next

Range(\& n).Sort Key1:=Range(\Order1:=xlAscending, Key2:=Range(\_ , Order2:=xlAscending, Key3:=Range(\Order3:=xlAscending, Header:= _ xlGuess For i = 3 To n

If Cells(i, 2) <> Cells(i - 1, 2) Then r = r + 1

ReDim Preserve Arr1(1 To r) Arr1(r) = i End If Next

Application.DisplayAlerts = False For j = 1 To r r3 = 0: r2 = 0 If j <> r Then

js = Arr1(j + 1) - 1

Else js = n End If ks = Arr1(j)

If js - ks + 1 > 1 Then

Cells(ks, 1).Resize(js - ks + 1, 1).Merge Cells(ks, 2).Resize(js - ks + 1, 1).Merge Cells(ks, 3).Resize(js - ks + 1, 1).Merge End If Cells(ks, 1) = j For ii = ks To js If ii = ks Then r2 = r2 + 1

ReDim Preserve Arr2(1 To r2) Arr2(r2) = ii

ElseIf Cells(ii, 4) <> Cells(ii - 1, 4) Then r2 = r2 + 1

ReDim Preserve Arr2(1 To r2) Arr2(r2) = ii End If Next

For ii = 1 To r2 If ii <> r2 Then

js1 = Arr2(ii + 1) - 1 Else js1 = js End If ks1 = Arr2(ii)

If js1 - ks1 + 1 > 1 Then

Cells(ks1, 4).Resize(js1 - ks1 + 1, 1).Merge For jj = ks1 To js1 If jj <> ks1 Then

Cells(ks, 7) = Cells(ks, 7) + Cells(jj, 7) End If Next

Cells(ks1, 5).Resize(js1 - ks1 + 1, 1).Merge Cells(ks1, 6).Resize(js1 - ks1 + 1, 1).Merge Else

If ii <> 1 Then

Cells(ks, 7) = Cells(ks, 7) + Cells(ks1, 7)

End If End If Next

Cells(ks, 7).Resize(js - ks + 1, 1).Merge For ii = ks To js If ii = ks Then r3 = r3 + 1

ReDim Preserve Arr3(1 To r3) Arr3(r3) = ii

ElseIf Cells(ii, 8) <> Cells(ii - 1, 8) Then r3 = r3 + 1

ReDim Preserve Arr3(1 To r3) Arr3(r3) = ii End If Next

For ii = 1 To r3 If ii <> r3 Then

js1 = Arr3(ii + 1) - 1 Else js1 = js End If ks1 = Arr3(ii)

If js1 - ks1 + 1 > 1 Then

Cells(ks1, 8).Resize(js1 - ks1 + 1, 1).Merge For jj = ks1 To js1 If jj <> ks1 Then

Cells(ks1, 9) = Cells(ks1, 9) + Cells(jj, 9) Cells(ks1, 10) = Cells(ks1, 10) + Cells(jj, 10) End If

Cells(ks, 11) = Cells(ks, 11) + Cells(jj, 11) Next

Cells(ks1, 9).Resize(js1 - ks1 + 1, 1).Merge Cells(ks1, 10).Resize(js1 - ks1 + 1, 1).Merge Else

If ii <> 1 Then

Cells(ks, 11) = Cells(ks, 11) + Cells(ks1, 11) End If End If Next

Cells(ks, 11).Resize(js - ks + 1, 1).Merge

Next

Range(\& n).Borders.LineStyle = 1 Application.DisplayAlerts = True Application.ScreenUpdating = True End Sub

三、代码详解

1、Dim d(1 To 3) As New dictionary ：本例是前期绑定的，先引用了脚本运行时库，声明了3个元素的数组为新字典。

2、x(1) = Arr(i, 2) ：把生产型号赋给变量x(1)。

3、d(1)(x(1)) = d(1)(x(1)) + Arr(i, 3) ：把相同生产型号和它的生产数量加入字典d(1)，

达到汇总的目的。

4、x(2) = Arr(i, 2) & \ ：把生产型号和返修原因连起来赋给变量x(2)。

5、d(2)(x(2)) = d(2)(x(2)) + Arr(i, 5) ： 把相同生产型号和相同返修原因的返修数量加入字典d(2)，达到汇总的目的。

6、x(3) = Arr(i, 2) & \ ：把生产型号和返修原因和报废原因连起来赋给变量x(3)。 7、d(3)(x(3)) = d(3)(x(3)) + Arr(i, 7) ：把相同生产型号和相同返修原因和相同报废原因的报废数量加入字典d(3)，达到汇总的目的。

8、For i = 1 To 3 ：用一个循环运用字典的keys方法和items方法把3个字典的关键字和它们的项赋给对应的变量。 9、Sheet4.Activate ：激活表4。

10、[a3:k1000].ClearContents ：清空A3：K1000单元格区域。

11、[a3:k1000].UnMerge ：将该区域所有的合并单元格分解为独立的单元格。 12、[a3:k1000].Borders.LineStyle = xlNone ：去除该区域所有的单元格边框。

13、[i3].Resize(d(3).Count, 1) = Application.Transpose(t(3)) ：把报废数量汇总值的一维数组转置后赋给I3开始的单元格区域。 14、n = 2 ：把2赋给变量n。因为循环中要用到n=n+1，而汇总表的起始行是第3行，所以把n的初值定为2。

15、For i = 0 To UBound(k(3)) ：在字典d(3)中逐一循环。

16、aa = Split(k(3)(i), \ ：VBA函数Split在第6例已经讲过了。把字典d(3)的关键字分解后赋给变量aa。

17、n = n + 1 ：在循环中每循环一次行数就加1。

18、Cells(n, 2) = aa(0) ：把aa数组的第1个元素aa(0)，即生产型号，赋给对应的单元格；下面两句分别把aa数组的第2个元素aa(1)，即返修原因，赋给对应的单元格；把aa数组的第3个元素aa(2)，即报废原因，赋给对应的单元格。 19、For i = 3 To n ：从第3行开始逐行循环。

20、For j = 0 To UBound(k(1)) ：在一维数组k(1)中循环。 21、If Cells(i, 2) = k(1)(j) Then ：如果生产型号等于字典d(1)的关键字时执行下面的语句。 22、Cells(i, 3) = t(1)(j) ：把这个生产型号的生产数量赋给C列单元格。

23、Cells(i, 10) = Cells(i, 9) / Cells(i, 3) ：把报废数量除以生产数量得到的报废率赋给J列单元格。

24、Cells(i, 11) = Cells(i, 10): Exit For ：把报废率赋给K列单元格。退出For j的循环。 25、For j = 0 To UBound(k(2)) ：在一维数组k(2)中循环。

26、If Cells(i, 2) & \ ：如果把生产型号和返修原因连起来的值

等于字典d(2)的一个关键字时，执行下面的代码。

27、Cells(i, 5) = t(2)(j) ：把相同生产型号和相同返修原因的返修数量赋给E列单元格。 28、Cells(i, 6) = Cells(i, 5) / Cells(i, 3) ：把返修数量除以生产数量得到的返修率赋给F列单元格。

29、Cells(i, 7) = Cells(i, 6): Exit For ：把返修率赋给G列单元格。退出For j的循环。 30、Range(\n).Sort Key1:=Range(\Order1:=xlAscending, Key2:=Range(\Order2:=xlAscending, Key3:=Range(\ ：本句开始给表格数据设置格式了。本句是对A3开始的单元格区域按B3_升序、D3_升序、H3_升序排序。

31、For i = 3 To n ：从第3行开始逐行循环。 32、If Cells(i, 2) <> Cells(i - 1, 2) Then ：如果B列单元格的值与上一行单元格不相等则执行下面的代码。

33、r = r + 1 ：变量r加1以后赋给r。

34、ReDim Preserve Arr1(1 To r) ：重新声明动态数组的大小。Preserve是ReDim 语句的关键字，当改变原有数组最末维的大小时，使用此关键字可以保持数组中原来的数据。

35、Arr1(r) = i ：把单元格所在的行数赋给数组。经过这轮循环就得到了各个生产型号的第一行的行数。也得到了生产型号的总数为r个。

36、Application.DisplayAlerts = False ：把显示警告设置为关闭，因为下面要合并单元格，Excel会显示一个警告对话框来打断代码的运行，所以先关闭此功能。 37、For j = 1 To r ：在所有的生产型号中逐一循环。 38、r3 = 0: r2 = 0 ：把两个变量设置为零。

39、If j <> r Then ：如果j不等于最后一个生产型号时，执行下面的代码。 40、js = Arr1(j + 1) – 1 ：把下一个生产型号开始行的上面一行的行数赋给js。 41、否则把最后一行的行数n赋给js变量。

42、ks = Arr1(j) ：把生产型号的开始行的行数赋给变量ks。

43、If js - ks + 1 > 1 Then ：如果结束行减去开始行再加1的值大于1，就说明这个型号有多行需要合并，执行下面的代码。

44、Cells(ks, 1).Resize(js - ks + 1, 1).Merge ：A列对应的单元格合并；下面B列和C列相应的单元格也合并。

45、Cells(ks, 1) = j ：A列依次填入序号。

46、For ii = ks To js ：从开始行到结束行逐一循环。

47、If ii = ks Then ：这个循环是为了求得D列返修原因是否有需要合并的单元格，如果ii = ks即是同一个生产型号中第一个返修原因的时候，把行数赋给动态数组，否则如果不等于上一行D列单元格的值时，把行数赋给动态数组的下一个元素。经过这轮循环就得到了这个生产型号每一个返修原因的第一行的行数。也得到了返修原因的总数为r2个。

48、For ii = 1 To r2 ：在这个循环中，把D列、E 列F列相同的返修原因单元格合并，也汇总了G列的总返修率。

49、Cells(ks, 7).Resize(js - ks + 1, 1).Merge ：把G列的总返修率单元格区域合并。

50、For ii = ks To js ：从开始行到结束行逐一循环。这个循环是为了求得H列报废原因是否有需要合并的单元格，经过这轮循环就得到了这个生产型号每一个报废原因的第一行的行数。也得到了报废原因的总数为r3个。

51、For ii = 1 To r3 ：在这个循环中，把H 列、I 列J 列相同的报废原因、报废数量

和报废率单元格合并，也汇总了K列的总报废率。

52、Range(\ ：把A3开始的单元格区域设置边框。 53、Application.DisplayAlerts = True ：开启程序显示警告。 54、Application.ScreenUpdating = True ：开启屏幕更新。

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

图 实例12-2示例

后语

常见字典用法实例集锦到此告一段落了。字典就象一个二维数组Arr(1 to n,1 to 2)，不过它的第2维的最大上界为2，相当于2列单元格，第1列存放的是关键字，这个关键字是除了数组以外的任何类型；第2列存放的是这个关键字对应的项，它可以是数据的任何类型。

我收集的和接触到有关字典的实例的数量有限，一定会有更好更有代表性的实例没有接触到，希望有心人能提供出来，供大家学习分享。 谢谢大家！

本文来源：https://www.bwwdw.com/article/ai8o.html