常见字典用法集锦及代码详解

蓝桥玄霜

前言
凡是上过学校的人都使用过字典，从新华字典、成语词典，到英汉字典以及各种各样数不胜数的专业字典，字典是上学必备的、经常查阅的工具书。有了它们，我们可以很方便的通过查找某个关键字，进而查到这个关键字的种种解释，非常快捷实用。
凡是上过EH论坛的想学习VBA里面字典用法的，几乎都看过研究过northwolves狼版主、oobird版主的有关字典的精华贴和经典代码。我也是从这里接触到和学习到字典的，在此，对他们表示深深的谢意，同时也对很多把字典用得出神入化的高手们致敬，从他们那里我们也学到了很多，也得到了提高。
字典对象只有4个属性和6个方法，相对其它的对象要简洁得多，而且容易理解使用方便，功能强大，运行速度非常快，效率极高。深受大家的喜爱。
本文希望通过对一些字典应用的典型实例的代码的详细解释来给初次接触字典和想要进一步了解字典用法的朋友提供一点备查的参考资料，希望大家能喜欢。
给代码注释估计是大家都怕做的，因为往往是出力不讨好的，稍不留神或者自己确实理解得不对，还会贻误他人。所以下面的这些注释如果有不对或者不妥当的地方，请大家跟帖时指正批评，及时改正。

字典的简介
字典（Dictionary）对象是微软Windows脚本语言中的一个很有用的对象。
附带提一下，有名的正则表达式（RegExp）对象和能方便处理驱动器、文件夹和文件的（FileSystemObject ）对象也是微软Windows脚本语言中的一份子。
字典对象相当于一种联合数组，它是由具有唯一性的关键字（Key）和它的项（Item）联合组成。就好像一本字典书一样，是由很多生字和对它们对应的注解所组成。比如字典的“典”字的解释是这样的：
“典”字就是具有唯一性的关键字，后面的解释就是它的项，和“典”字联合组成一对数据。

常用关键字英汉对照：
Dictionary                字典
Key                        关键字
Item                        项，或者译为 条目


字典对象的方法有6个：Add方法、Keys方法、Items方法、Exists方法、Remove方法、RemoveAll方法。
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”。

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函数精选合集”。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("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”了，字典中的关键字是唯一的，不能添加重复的关键字。

[ 本帖最后由 蓝桥玄霜 于 2010-10-24 19:55 编辑 ]

蓝桥玄霜

实例1  普通常见的求不重复值问题
一、问题的提出：
表格中人员有很多是重复的，要求编写一段代码，把重复的人员姓名以及重复的次数求出来，复制到另一个表格中。

1. Sub cfz()
   
2. Dim i&, Myr&, Arr
   
3. Dim d, k, t
   
4. Set d = CreateObject("Scripting.Dictionary")
   
5. Myr = Sheet1.[a65536].End(xlUp).Row
   
6. Arr = Sheet1.Range("a1:g" & Myr)
   
7. For i = 2 To UBound(Arr)
   
8.     d(Arr(i, 3)) = d(Arr(i, 3)) + 1
   
9. Next
   
10. k = d.keys
    
11. t = d.items
    
12. Sheet2.Activate
    
13. [a2].Resize(d.Count, 1) = Application.Transpose(k)
    
14. [b2].Resize(d.Count, 1) = Application.Transpose(t)
    
15. [a1].Resize(1, 2) = Array("姓名", "重复个数")
    
16. Set d = Nothing
    
17. End Sub
    

复制代码

三、代码详解
1、Dim i&, Myr&, Arr ：变量i和Myr声明为长整型变量。 也可以写为 Dim Myr As Long 。Long 的类型声明字符为(&)。Arr后面没有写明数据类型，默认就是可变型数据类型(Variant)。
2、Set d = CreateObject("Scripting.Dictionary")：创建字典对象，并把字典对象赋给变量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("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  ：释放字典内存。

实例2  求多表的不重复值问题
一、问题的提出：
一工作簿里面有3张工作表上，每张表格的A列都是姓名列，所有这些姓名中有些是重复的，要求编写一段代码，在另一个工作表上显示不重复的姓名。
如图实例2－1所示。

图  实例2-1  

这个问题也很适合用字典来解决。代码如下：

1. Sub bcfz()
   
2. Dim i&, Myr&, Arr
   
3. Dim d, k, t, Sht As Worksheet
   
4. Set d = CreateObject("Scripting.Dictionary")
   
5. For Each Sht In Sheets
   
6.     If Sht.Name <> "Sheet4" Then
   
7.         Myr = Sht.[a65536].End(xlUp).Row
   
8.         Arr = Sht.Range("a2:a" & Myr)
   
9.         For i = 1 To UBound(Arr)
   
10.             d(Arr(i, 1)) = ""
    
11.         Next
    
12.     End If
    
13. Next
    
14. k = d.keys
    
15. Sheet4.[a3].Resize(d.Count, 1) = Application.Transpose(k)
    
16. Set d = Nothing
    
17. End Sub
    

复制代码

三、代码详解
1、For Each Sht In Sheets ：For Each…Next循环结构，这种形式是VBA特有的，用于对对象的循环非常适用。意思是在所有的工作表中依次循环。
2、If Sht.Name <> "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

[ 本帖最后由 蓝桥玄霜 于 2010-10-20 11:11 编辑 ]

蓝桥玄霜

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

1. Sub 余1余5()  ‘by:狼版主
   
2. Dim dic As Object, i As Long, arr
   
3. Set dic = CreateObject("Scripting.Dictionary")
   
4. For i = 1 To 1000
   
5. dic.Add i & IIf(Abs(i Mod 6 - 3) = 2, "@", ""), ""
   
6. Next
   
7. arr = WorksheetFunction.Transpose(Filter(dic.keys, "@"))
   
8. [a1].Resize(UBound(arr), 1) = arr
   
9. [a:a].Replace "@", ""
   
10. Set dic = Nothing
    
11. 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  拆分数据不重复
一、问题的提出：
有一列各种手机品牌型号的数据，要求编写一段代码，按照品牌划分成没有重复数据的三大类。
二、代码：

1. Sub caifen()
   
2. Dim Myr&, Arr, x&
   
3. Dim d, d1, d2, i&, j&
   
4. Set d = CreateObject("Scripting.Dictionary")
   
5. Set d1 = CreateObject("Scripting.Dictionary")
   
6. Set d2 = CreateObject("Scripting.Dictionary")
   
7. Myr = [a65536].End(xlUp).Row
   
8. Arr = Range("a2:a" & Myr)
   
9. Range("c2:e" & Myr).ClearContents
   
10. my = Array("MOTO", "诺基亚", "三星", "索爱")
    
11. gc = Array("OPPO", "联想", "天语", "金立", "步步高", "波导", "TCL", "酷派")
    
12. For x = 1 To UBound(Arr)
    
13.     For i = 0 To UBound(my)
    
14.         If InStr(Arr(x, 1), my(i)) > 0 Then
    
15.             d(Arr(x, 1)) = ""
    
16.             GoTo 100
    
17.         End If
    
18.     Next i
    
19.     For j = 0 To UBound(gc)
    
20.         If InStr(Arr(x, 1), gc(j)) > 0 Then
    
21.             d1(Arr(x, 1)) = ""
    
22.             GoTo 100
    
23.         End If
    
24.     Next j
    
25.     d2(Arr(x, 1)) = ""
    
26. 100:
    
27. Next x
    
28. Range("c2").Resize(UBound(d.keys) + 1, 1) = Application.Transpose(d.keys)
    
29. Range("d2").Resize(UBound(d1.keys) + 1, 1) = Application.Transpose(d1.keys)
    
30. Range("e2").Resize(UBound(d2.keys) + 1, 1) = Application.Transpose(d2.keys)
    
31. 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句分别把字典的关键字数组转置后赋给相应的单元格区域。

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

四、山菊花版主的代码：

1. Sub 拆分()
   
2.     Dim pp1$, pp2$, nRow%, ds, Brr(), s(1 To 3) As Integer
   
3.     Set ds = CreateObject("scripting.dictionary")
   
4.     pp1 = Join(WorksheetFunction.Transpose(Range(Range("g2"), Range("g1").End(xlDown))), ",")
   
5.     pp2 = Join(WorksheetFunction.Transpose(Range(Range("h2"), Range("h1").End(xlDown))), ",")
   
6.     nRow = Range("a1").End(xlDown).Row
   
7.     Arr = Range("a1:a" & nRow)
   
8.     ReDim Brr(1 To nRow, 1 To 3)
   
9.     For i = 2 To nRow
   
10.         If Not ds.Exists(Arr(i, 1)) Then
    
11.             ds(Arr(i, 1)) = ""
    
12.             If pp1 Like "*" & Left(Arr(i, 1), 2) & "*" Then
    
13.                 s(1) = s(1) + 1
    
14.                 Brr(s(1), 1) = Arr(i, 1)
    
15.             ElseIf pp2 Like "*" & Left(Arr(i, 1), 2) & "*" Then
    
16.                 s(2) = s(2) + 1
    
17.                 Brr(s(2), 2) = Arr(i, 1)
    
18.             Else
    
19.                 s(3) = s(3) + 1
    
20.                 Brr(s(3), 3) = Arr(i, 1)
    
21.             End If
    
22.         End If
    
23.     Next
    
24.     Range("c2:e" & nRow) = Brr
    
25. 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]单元格开始的区域中。

[ 本帖最后由 蓝桥玄霜 于 2010-10-21 10:24 编辑 ]

蓝桥玄霜

[/code]实例5  前期绑定的字典实例
一、问题的提出：
有多列多行数据，其中有重复的行，要求编写一段代码，求得不重复的行数据。
如图实例5-1所示。[code]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
[/code]三、代码详解
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所示。

实例6  多条件复杂汇总
一、问题的提出：
有一个表格，需要对其中多个条件相同的数量进行合并汇总，并且要有汇总的明细数据，要求编写一段代码，实现这样的合并同类项的要求。
二、代码：[code]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("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
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       
[/code]三、代码详解
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("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函数精选合集”。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所示。

[ 本帖最后由 蓝桥玄霜 于 2010-10-22 10:04 编辑 ]

蓝桥玄霜

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

1. Private Sub CommandButton1_Click()  ‘by:oobird
   
2. Dim d As Object, rng, i%, j%, arr
   
3. Set d = CreateObject("Scripting.Dictionary")
   
4. rng = Range("a3:f" & [a65536].End(xlUp).Row)
   
5. ReDim arr(1 To UBound(rng), 1 To 4)
   
6. For i = 1 To UBound(rng)   
   
7. d(CStr(rng(i, 1))) = i
   
8. Next i
   
9. For j = 3 To 5 Step 2
   
10. For i = 1 To Cells(65536, j).End(xlUp).Row - 2
    
11. If d(CStr(rng(i, j))) <> "" Then
    
12. arr(d(CStr(rng(i, j))), j - 2) = rng(i, j)     
    
13. arr(d(CStr(rng(i, j))), j - 1) = rng(i, j + 1)
    
14. End If
    
15. Next i
    
16. Next j
    
17. [c3].Resize(UBound(rng), 4) = arr
    
18. End Sub       
    

复制代码

三、代码详解
1、Dim d As Object, rng, i%, j%, arr ：声明各个变量。
2、Set d = CreateObject("Scripting.Dictionary") ：创建字典对象d。
3、rng = Range("a3:f" & [a65536].End(xlUp).Row)  ：把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))) <> "" Then ：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所示。
实例8  2级动态数据有效性问题
一、问题的提出：
A列是源名称，中间有空格，B列为各个源名称对应的数目不同的代号，C列是目标名称来源于源名称，要求在C列设置不重复的、没有空格的数据有效性供选择；同时D列目标代号，要求随着C列选择的目标名称的不同，提供对应的代号供选择，是为第2级数据有效性。

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

1. Private Sub Worksheet_SelectionChange(ByVal Target As Range)
   
2. If Target.Count > 1 Then Exit Sub
   
3. If Target.Column <> 4 And Target.Column <> 3 Then Exit Sub
   
4. Dim d, i&, Myr&, Arr, r%, Arr1(), cp$, ks&, js&, j&
   
5. Set d = CreateObject("Scripting.Dictionary")
   
6. Myr =[b65536].End(xlUp).Row
   
7. Arr = Range("a2:b" & Myr)
   
8. If Target.Column = 3 Then
   
9.     For i = 1 To UBound(Arr)
   
10.         If Arr(i, 1) <> "" Then
    
11.             d(Arr(i, 1)) = ""
    
12.         End If
    
13.     Next
    
14.     With Target.Validation
    
15.         .Delete
    
16.         .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, _
    
17.         Operator:=xlBetween, Formula1:=Join(d.keys, ",")
    
18.     End With
    
19.     Target.Offset(0, 1) = ""
    
20. ElseIf Target.Column = 4 And Target.Offset(0, -1) <> "" Then
    
21.     For i = 1 To UBound(Arr)
    
22.         If Arr(i, 1) <> "" Then
    
23.             r = r + 1
    
24.             ReDim Preserve Arr1(1 To r)
    
25.             Arr1(r) = i
    
26.         End If
    
27.     Next i
    
28.     For i = 1 To r
    
29.         If Arr(Arr1(i), 1) = Target.Offset(0, -1).Text Then
    
30.             If i <> r Then
    
31.                 js = Arr1(i + 1) - 1
    
32.             Else
    
33.                 js = Myr - 1
    
34.             End If
    
35.             ks = Arr1(i)
    
36.             For j = ks To js
    
37.                 cp = cp & Arr(j, 2) & ","
    
38.             Next
    
39.         End If
    
40.     Next i
    
41.     cp = Left(cp, Len(cp) - 1)
    
42.     With Target.Validation
    
43.         .Delete
    
44.         .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, _
    
45.         Operator:=xlBetween, Formula1:=cp
    
46.     End With
    
47.     Target = Split(cp, ",")(0)
    
48. End If
    
49. Set d = Nothing
    
50. 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列，就会遗漏一些数据。
5、If Target.Column = 3 Then ：现在分两种情况判断，如果点击的目标单元格是C列的，那么执行下面的代码。
6、If Arr(i, 1) <> "" Then ：在数组Arr之间逐一循环，如果A列数组的值不等于空，就作为关键字加入字典d。这样就排除了空值进入字典。
7、With Target.Validation ：这里使用了With语句，With语句为我们提供了十分简便的对象引用手段。使用它有3个优点：可以减少代码的输入量、增加代码的可读性。改善代码的执行效率。在End With之前的语句都是对目标单元格的有效性对象的各个属性进行设置。
8、.Delete ：先删除该单元格的数据有效性。注意Delete前有个小圆点，在小圆点之前就省略了Target.Validation，即减少了代码的输入量。这个小圆点不能遗漏，否则会出错。
9、.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, _
Operator:=xlBetween, Formula1:=Join(d.keys, ",") ：Add是有效性对象的方法，向指定区域内添加数据有效性检验。参数Type是数据有效性类型，当类型等于xlValidateList时，后面的公式1参数Formula1 必须包含以逗号分隔的取值列表。参数AlertStyle是出错警告样式，这里是停止样式；参数Operator是数据有效性运算符，有大于、小于、大于或等于、小于或等于、介于、不介于、等于、不等于等等，这里取介于；公式1参数Formula1的值用了VBA函数Join，把字典的关键字用逗号分隔后连接起来赋给公式1参数。这样，目标单元格那的数据有效性中就没有重复值了。
10、Target.Offset(0, 1) = "" ：给目标单元格设置了数据有效性以后，把它同行D列单元格的值清除。这是为了确保D列的值只与C列的目标名称相对应。
11、ElseIf Target.Column = 4 And Target.Offset(0, -1) <> "" Then ：否则如果目标单元格是D列的，并且同行C列单元格不是空的情况下，执行这下面的代码。Offset属性的详解可见前面实例6的第2条解释。
12、For i = 1 To UBound(Arr) ：在数组Arr之间逐一循环。
13、If Arr(i, 1) <> "" Then ：如果A列数组的值不等于空，就执行下面的代码。
14、r = r + 1 ：变量r累加。
15、ReDim Preserve Arr1(1 To r) ：重新声明动态数组的大小，Preserve是关键字，当改变原有数组最末维的大小时，使用此关键字可以保持数组中原来的数据。这句是改变动态数组大小的最常用语句，不能忘记Preserve关键字。
16、Arr1(r) = i ：把关键字在数组Arr中行的位置赋给新的动态数组Arr1(r)。这个循环可求得A列每一个源名称所在的行的位置。
17、For i = 1 To r ：上面的循环求得了一共有r个源名称，逐一循环。
18、If Arr(Arr1(i), 1) = Target.Offset(0, -1).Text Then ：如果C列的目标名称等于源名称时执行下面的代码。
19、If i <> r Then ：如果i不等于r时执行下面的代码。
20、js = Arr1(i + 1) – 1 ：把下一个源名称所在的行数-1以后赋给变量js，这样来求得每一个源名称的开始和结束的位置。
21、js = Myr – 1 ：否则就是最后一行－1的只赋给变量js（最后一个源名称在数组中的位置）。
22、ks = Arr1(i) ：把数组的值赋给变量ks：得到每一个源名称的起始位置。
23、For j = ks To js ：从每一个源名称的起始位置到结束位置逐一循环。
24、cp = cp & Arr(j, 2) & "," ：把相应的代号与逗号连接起来组成的字符串赋给变量cp。
25、cp = Left(cp, Len(cp) - 1) ：用了两个VBA函数Left和Len把去掉末位的逗号。
26、With 语句解释同上，为D列单元格设置了第2级数据有效性。
27、Target = Split(cp, ",")(0) ：按照问题的第3个要求，在目标名称确定后，在目标代号相应位置自动生成目标名称的第一个代号。因为Split得到的是一个以0为下界的一维函数，所以它的第一个元素就用(0)来表示。

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

[ 本帖最后由 蓝桥玄霜 于 2010-10-23 21:29 编辑 ]

蓝桥玄霜

实例9  字典取行数，数组重新赋值
一、问题的提出：
要求编写一段代码，求得B列不重复的名字，其相应的A列和D列分别用" "连起来，而相应的E列F列的数值分别相加汇总。
代码执行前如图实例8-1所示。
二、代码：

1. Sub yy()  'by:Zamyi
   
2. Dim d As New Dictionary, R
   
3. Dim k, i&, j&
   
4. R = Sheet1.UsedRange
   
5. k = 1
   
6. For i = 2 To UBound(R)
   
7.     R(i, 2) = Replace(Replace(R(i, 2), "（", "("), "）", ")")
   
8.     If d.Exists(R(i, 2)) Then
   
9.         R(d(R(i, 2)), 1) = R(d(R(i, 2)), 1) & " " & R(i, 1)
   
10.         R(d(R(i, 2)), 4) = R(d(R(i, 2)), 4) & " " & R(i, 4)
    
11.         R(d(R(i, 2)), 5) = Val(R(d(R(i, 2)), 5)) + R(i, 5)
    
12.         R(d(R(i, 2)), 6) = Val(R(d(R(i, 2)), 6)) + R(i, 6)
    
13.     Else
    
14.         k = k + 1
    
15.         d(R(i, 2)) = i
    
16.         For j = 1 To UBound(R, 2)
    
17.             R(k, j) = R(i, j)
    
18.         Next
    
19.   End If
    
20. Next
    
21. With Sheet2
    
22.     .Cells.ClearContents
    
23.     .Cells.Borders.LineStyle = xlNone
    
24.     .[a1:F1].Resize(d.Count + 1) = R
    
25.     .[a1:F1].Resize(d.Count + 1).Borders.LineStyle = 1
    
26. End With
    
27. Set d = Nothing
    
28. End Sub       
    

复制代码

三、代码详解
1、R = Sheet1.UsedRange ：把表1的已经使用了的单元格区域的值赋给变量R。
2、k = 1 ：变量k赋初值1。
3、For i = 2 To UBound(R)  ：由于第一行是表头，所以从第2行开始循环。
4、R(i, 2) = Replace(Replace(R(i, 2), "（", "("), "）", ")") ：由于源数据中用了不统一的括号，所以加了这句把里面中文括号统一替换为英文括号。这句用了两次VBA函数Replace，一次替换前半个，另一次替换后半个。Replace函数有6个参数，详细请查阅VBA帮助文件。如果在这里解释，篇幅太长了，也冲淡了字典的主题。
5、If d.Exists(R(i, 2)) Then ：这句用字典的Exists方法进行判断，如果字典中存在R(i, 2)这个关键字，那么执行下面的代码。
6、这里先解释，Else如果上面的判断不成立，即字典中不存在这个关键字时，要执行下面的代码。
7、k = k + 1 ：变量k+1以后再赋给k。
8、d(R(i, 2)) = i ：公司名字作为关键字，对应的项是它所在的行，把它们加入字典d。
9、For j = 1 To UBound(R, 2) ：知道了这个关键字所在的行，下面这个循环就是重新给数组同一行的各个元素赋值。UBound(R, 2)是用VBA函数Ubound求得数组R的第2维的最大上界。比如本例R数组第1维的最大上界是8，有8行数据；而第2维的最大上界是6，有6列数据。本循环j就是从第1列到第6列依次循环。
10、R(k, j) = R(i, j) ：把i行j列的数组元素赋给k行j列的R数组元素。
11、R(d(R(i, 2)), 1) = R(d(R(i, 2)), 1) & " " & R(i, 1) ：再回来说如果R(i, 2)这个关键字存在，则执行这条代码。在这之前，这关键字已经加入字典了，它的同一行的各个数组元素也重新赋过值了，所以根据问题的要求，把A列的数据用" "连起来再赋给A列这个数组元素。
12、R(d(R(i, 2)), 4) = R(d(R(i, 2)), 4) & " " & R(i, 4) ：D列数据同上。
13、R(d(R(i, 2)), 5) = Val(R(d(R(i, 2)), 5)) + R(i, 5) ：E 列数据要相加，这里用了VBA函数Val，把E列数组元素转为数值以后相加汇总。下句类同。
14、With Sheet2 ：With语句，前面介绍过的。
15、.Cells.ClearContents ：清空表2所有的数据。Cells是工作表对象的属性，指工作表所有的单元格；ClearContents是它的方法，清除里面的公式、数据，但是保留格式设置。
16、.Cells.Borders.LineStyle = xlNone ：清除表2所有的边框。Borders是Cells的属性，意思是单元格的边框；LineStyle是边框的属性，为边框的线型，它有直线、虚线、点划线等等，这里取值xlNone是清除边框。
17、.[a1:F1].Resize(d.Count + 1) = R ：把数组R的值赋给表2A1单元格开始的区域。
18、.[a1:F1].Resize(d.Count + 1).Borders.LineStyle = 1 ：给这些单元格添加边框，线型为直线。

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

实例10  先字典求得行后显示整行数据
一、问题的提出：
有3列数据，要求编写一段代码，如果C列名次、A列主排相同时，根据B列次排最大的只保留一行。
解题思路：先对3列数据按主要关键字名次_升序，次要关键字主排_升序，第3关键字次排_降序进行排序，然后运用字典，以”名次|主排” 作为关键字，它所在的行作为关键字的项加入字典，最后根据行引用相对的单元格值。

代码执行前如图实例10-1所示。
二、代码：

1. Sub pmc()
   
2. Dim i&, Myr&, Arr
   
3. Dim d, x, rng
   
4. Application.ScreenUpdating = False
   
5. Set d = CreateObject("Scripting.Dictionary")
   
6. Sheet1.Activate
   
7. Myr = [a65536].End(xlUp).Row
   
8. Range("A1:C" & Myr).Sort Key1:=Range("C2"), Order1:=xlAscending, Key2:=Range( _
   
9.         "A2"), Order2:=xlAscending, Key3:=Range("B2"), Order3:=xlDescending, _
   
10.         Header:=xlYes
    
11. Arr = Range("a2:c" & Myr)
    
12. For i = 1 To UBound(Arr)
    
13.     x = Arr(i, 1) & "|" & Arr(i, 3)
    
14.     If Not d.exists(x) Then
    
15.         d.Add x, i + 1
    
16.     End If
    
17. Next
    
18. [e:g].ClearContents
    
19. [e2].Resize(d.Count, 1) = Application.Transpose(d.items)
    
20. For Each rng In [e2].Resize(d.Count, 1)
    
21.     rng.Resize(1, 3) = Cells(rng, 1).Resize(1, 3).Value
    
22. Next
    
23. Set d = Nothing
    
24. Application.ScreenUpdating = True
    
25. End Sub
    

复制代码

三、代码详解
1、Application.ScreenUpdating = False ：关闭屏幕更新。关闭屏幕更新可加快宏的执行速度。请记住当宏结束执行时，将 ScreenUpdating 属性设回到 True。
2、Range("A1:C" & Myr).Sort Key1:=Range("C2"), Order1:=xlAscending, Key2:=Range("A2"), Order2:=xlAscending, Key3:=Range("B2"), Order3:=xlDescending, _
Header:=xlYes ：对ABC三列进行排序。主要关键字Key1名次_升序，次要关键字Key2主排_升序，第3关键字Key3次排_降序。
3、Arr = Range("a2:c" & Myr) ：把ABC列数据赋给变量Arr。
4、For i = 1 To UBound(Arr)  ：i从1到数组Arr的最大上界逐一循环。
5、x = Arr(i, 1) & "|" & Arr(i, 3) ：把主排和”|”和名次连起来赋给变量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所示。
doc文件（全）请到1楼下载。

[ 本帖最后由 蓝桥玄霜 于 2010-10-24 19:24 编辑 ]

蓝桥玄霜

实例11  关键字赋给两列后用Replace方法
一、问题的提出：
有如图实例11-1所示的工资表，要求编写一段代码，运用VBA自动生成1季度的工资表。
解题思路：先把性别和姓名连起来作为关键字求得人员的不重复值，然后通过循环查找关键字获得其各月的工资，最后用Replace方法替换两列关键字区域得到各自的数据。
代码执行前如图实例11-1所示。
二、代码：

1. Sub yy()
   
2. Dim d, k, t, i&, j&, Arr, x, r1
   
3. Set d = CreateObject("Scripting.Dictionary")
   
4. Arr = [a1].CurrentRegion
   
5. For i = 1 To UBound(Arr, 2) Step 3
   
6.     For j = 2 To UBound(Arr)
   
7.         If Arr(j, i) <> "" Then
   
8.              x = Arr(j, i) & "|" & Arr(j, i + 1)
   
9.              d(x) = ""
   
10.         End If
    
11.     Next
    
12. Next
    
13. k = d.keys
    
14. [a12:i1000].ClearContents
    
15. [a13].Resize(d.Count, 2) = Application.Transpose(k)
    
16. [a12:b12] = Array("性别", "姓名")
    
17. For i = 3 To UBound(Arr, 2) Step 3
    
18.     Cells(12, 2 + i / 3) = Cells(1, i)
    
19. Next
    
20. For i = 3 To UBound(Arr, 2) Step 3
    
21.     For j = 2 To UBound(Arr)
    
22.         If Arr(j, i) <> "" Then
    
23.             x = Arr(j, i - 2) & "|" & Arr(j, i - 1)
    
24.             Set r1 = [a13].Resize(d.Count, 1).Find(x, , , 1)
    
25.             Cells(r1.Row, 2 + i / 3) = Arr(j, i)
    
26.         End If
    
27.     Next
    
28. Next
    
29. [a13].Resize(d.Count, 1).Replace "|*", "", xlPart
    
30. [b13].Resize(d.Count, 1).Replace "*|", "", xlPart
    
31. 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) <> "" Then ：If-Then-Else控制结构可根据测试条件的结果改变程序执行的流程。本句测试条件是Arr(j, i) <> ""，判断性别是否为空白，如果不为空白则执行下面的语句，否则，执行Else下面的语句。
5、x = Arr(j, i) & "|" & Arr(j, i + 1) ：把性别和姓名中间加“|”连起来赋给变量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 "|*", "", xlPart ：Replace方法是Range对象的一个方法，其第1个参数是要查找的字符串，这里"|*"是竖线及后面所有的字符串；其第2个参数是替换字符串，这里替换为空；其第3个参数是精确查找还是模糊查找，xlPart常量的值＝2，可以用2代替它。本句是把姓名替换掉，只留下性别；下一句把B列中的性别替换掉，只留下姓名。
代码执行后如图实例11-2所示。

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

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

1. Sub bbhz()
   
2. Dim i&, Myr&, x(1 To 3), Arr, n%, aa, j&, Arr1(), r%, Arr2(), r2%, r3%, Arr3()
   
3. Dim d(1 To 3) As New dictionary, k(1 To 3), t(1 To 3), js, ks, ii%, jj&, ks1, js1
   
4. Application.ScreenUpdating = False
   
5. Myr = Sheet1.[a65536].End(xlUp).Row
   
6. Arr = Sheet1.Range("a3:g" & Myr)
   
7. For i = 1 To UBound(Arr)
   
8.     x(1) = Arr(i, 2)
   
9.     d(1)(x(1)) = d(1)(x(1)) + Arr(i, 3)
   
10.     x(2) = Arr(i, 2) & "|" & Arr(i, 4)
    
11.     d(2)(x(2)) = d(2)(x(2)) + Arr(i, 5)
    
12.     x(3) = Arr(i, 2) & "|" & Arr(i, 4) & "|" & Arr(i, 6)
    
13.     d(3)(x(3)) = d(3)(x(3)) + Arr(i, 7)
    
14. Next
    
15. For i = 1 To 3
    
16.     k(i) = d(i).Keys
    
17.     t(i) = d(i).Items
    
18. Next
    
19. Sheet4.Activate
    
20. [a3:k1000].ClearContents
    
21. [a3:k1000].UnMerge
    
22. [a3:k1000].Borders.LineStyle = xlNone
    
23. [i3].Resize(d(3).Count, 1) = Application.Transpose(t(3))
    
24. n = 2
    
25. For i = 0 To UBound(k(3))
    
26.     aa = Split(k(3)(i), "|")
    
27.     n = n + 1
    
28.     Cells(n, 2) = aa(0)
    
29.     Cells(n, 4) = aa(1)
    
30.     Cells(n, 8) = aa(2)
    
31. Next
    
32. For i = 3 To n
    
33.     For j = 0 To UBound(k(1))
    
34.         If Cells(i, 2) = k(1)(j) Then
    
35.             Cells(i, 3) = t(1)(j)
    
36.             Cells(i, 10) = Cells(i, 9) / Cells(i, 3)
    
37.             Cells(i, 11) = Cells(i, 10): Exit For
    
38.         End If
    
39.     Next
    
40.     For j = 0 To UBound(k(2))
    
41.         If Cells(i, 2) & "|" & Cells(i, 4) = k(2)(j) Then
    
42.             Cells(i, 5) = t(2)(j)
    
43.             Cells(i, 6) = Cells(i, 5) / Cells(i, 3)
    
44.             Cells(i, 7) = Cells(i, 6): Exit For
    
45.         End If
    
46.     Next
    
47. Next
    
48. Range("a3:k" & n).Sort Key1:=Range("b3"), Order1:=xlAscending, Key2:=Range("d3") _
    
49.         , Order2:=xlAscending, Key3:=Range("h3"), Order3:=xlAscending, Header:= _
    
50.         xlGuess
    
51. For i = 3 To n
    
52.     If Cells(i, 2) <> Cells(i - 1, 2) Then
    
53.         r = r + 1
    
54.         ReDim Preserve Arr1(1 To r)
    
55.         Arr1(r) = i
    
56.     End If
    
57. Next
    
58. Application.DisplayAlerts = False
    
59. For j = 1 To r
    
60.     r3 = 0: r2 = 0
    
61.     If j <> r Then
    
62.         js = Arr1(j + 1) - 1
    
63.     Else
    
64.         js = n
    
65.     End If
    
66.     ks = Arr1(j)
    
67.     If js - ks + 1 > 1 Then
    
68.         Cells(ks, 1).Resize(js - ks + 1, 1).Merge
    
69.         Cells(ks, 2).Resize(js - ks + 1, 1).Merge
    
70.         Cells(ks, 3).Resize(js - ks + 1, 1).Merge
    
71.     End If
    
72.     Cells(ks, 1) = j
    
73.     For ii = ks To js
    
74.         If ii = ks Then
    
75.             r2 = r2 + 1
    
76.             ReDim Preserve Arr2(1 To r2)
    
77.             Arr2(r2) = ii
    
78.         ElseIf Cells(ii, 4) <> Cells(ii - 1, 4) Then
    
79.             r2 = r2 + 1
    
80.             ReDim Preserve Arr2(1 To r2)
    
81.             Arr2(r2) = ii
    
82.         End If
    
83.     Next
    
84.     For ii = 1 To r2
    
85.         If ii <> r2 Then
    
86.             js1 = Arr2(ii + 1) - 1
    
87.         Else
    
88.             js1 = js
    
89.         End If
    
90.         ks1 = Arr2(ii)
    
91.         If js1 - ks1 + 1 > 1 Then
    
92.             Cells(ks1, 4).Resize(js1 - ks1 + 1, 1).Merge
    
93.             For jj = ks1 To js1
    
94.                 If jj <> ks1 Then
    
95.                 Cells(ks, 7) = Cells(ks, 7) + Cells(jj, 7)
    
96.                 End If
    
97.             Next
    
98.             Cells(ks1, 5).Resize(js1 - ks1 + 1, 1).Merge
    
99.             Cells(ks1, 6).Resize(js1 - ks1 + 1, 1).Merge
    
100.         Else
     
101.             If ii <> 1 Then
     
102.             Cells(ks, 7) = Cells(ks, 7) + Cells(ks1, 7)
     
103.             End If
     
104.         End If
     
105.     Next
     
106.     Cells(ks, 7).Resize(js - ks + 1, 1).Merge
     
107.     For ii = ks To js
     
108.         If ii = ks Then
     
109.             r3 = r3 + 1
     
110.             ReDim Preserve Arr3(1 To r3)
     
111.             Arr3(r3) = ii
     
112.         ElseIf Cells(ii, 8) <> Cells(ii - 1, 8) Then
     
113.             r3 = r3 + 1
     
114.             ReDim Preserve Arr3(1 To r3)
     
115.             Arr3(r3) = ii
     
116.         End If
     
117.     Next
     
118.     For ii = 1 To r3
     
119.         If ii <> r3 Then
     
120.             js1 = Arr3(ii + 1) - 1
     
121.         Else
     
122.             js1 = js
     
123.         End If
     
124.         ks1 = Arr3(ii)
     
125.         If js1 - ks1 + 1 > 1 Then
     
126.             Cells(ks1, 8).Resize(js1 - ks1 + 1, 1).Merge
     
127.             For jj = ks1 To js1
     
128.                 If jj <> ks1 Then
     
129.                     Cells(ks1, 9) = Cells(ks1, 9) + Cells(jj, 9)
     
130.                     Cells(ks1, 10) = Cells(ks1, 10) + Cells(jj, 10)
     
131.                 End If
     
132.                 Cells(ks, 11) = Cells(ks, 11) + Cells(jj, 11)
     
133.             Next
     
134.             Cells(ks1, 9).Resize(js1 - ks1 + 1, 1).Merge
     
135.             Cells(ks1, 10).Resize(js1 - ks1 + 1, 1).Merge
     
136.         Else
     
137.             If ii <> 1 Then
     
138.             Cells(ks, 11) = Cells(ks, 11) + Cells(ks1, 11)
     
139.             End If
     
140.         End If
     
141.     Next
     
142.         Cells(ks, 11).Resize(js - ks + 1, 1).Merge
     
143. Next
     
144. Range("a3:k" & n).Borders.LineStyle = 1
     
145. Application.DisplayAlerts = True
     
146. Application.ScreenUpdating = True
     
147. 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) & "|" & Arr(i, 4)  ：把生产型号和返修原因连起来赋给变量x(2)。
5、d(2)(x(2)) = d(2)(x(2)) + Arr(i, 5)  ： 把相同生产型号和相同返修原因的返修数量加入字典d(2)，达到汇总的目的。
6、x(3) = Arr(i, 2) & "|" & Arr(i, 4) & "|" & Arr(i, 6)  ：把生产型号和返修原因和报废原因连起来赋给变量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) & "|" & Cells(i, 4) = k(2)(j) Then ：如果把生产型号和返修原因连起来的值等于字典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("a3:k" & n).Sort Key1:=Range("b3"), Order1:=xlAscending, Key2:=Range("d3"), Order2:=xlAscending, Key3:=Range("h3"), Order3:=xlAscending, Header:= xlGuess ：本句开始给表格数据设置格式了。本句是对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:k" & n).Borders.LineStyle = 1 ：把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列存放的是这个关键字对应的项，它可以是数据的任何类型。
我收集的和接触到有关字典的实例的数量有限，一定会有更好更有代表性的实例没有接触到，希望有心人能提供出来，供大家学习分享。
谢谢大家！


                                                         2010-10
全本DOC文件请到1楼下载。

[ 本帖最后由 蓝桥玄霜 于 2010-10-24 19:29 编辑 ]

lzyamo3057

继续抢占沙发

lin82

跟贴备学！谢谢！

yvhgydn

占位置学习，不是为灌水，只为有个地儿