[数组字典] 常见字典用法集锦及代码详解

        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 方法从一个 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 属性。

        返回一个 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 。 　

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

        在一个 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./thread-387253-1-1.html          
        　

        设置或者返回在 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” 了，字典中的关键字是唯一的，不能添加重复的关键字。

        一、 问题的提出：
        表格中人员有很多是重复的，要求编写一段代码，把重复的人员姓名以及重复的次数求出来，复制到另一个表格中。 　
        二、代码 ：
        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
        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("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   ：释放字典内存。
        
        　

        一、 问题的提出：
        有 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, "@", ""), ""
        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-2 所示。
        
        

        一、 问题的提出：
        有一列各种手机品牌型号的数据，要求编写一段代码，按照品牌划分成没有重复数据的三大类。
        二、代码 ：
        Sub caifen()
        Dim Myr&, Arr, x&
        Dim d, d1, d2, i&, j&
        Set d = CreateObject("Scripting.Dictionary")
        Set d1 = CreateObject("Scripting.Dictionary")
        Set d2 = CreateObject("Scripting.Dictionary")
        Myr = [a65536].End(xlUp).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 句分别把字典的关键字数组转置后赋给相应的单元格区域。
        
        山菊花版主用了一个字典对象就解决了上述问题。让我们来学习一下。
        
        　
        四、山菊花版主的代码 ：
        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(xlDown))), ",")
            pp2 = Join(WorksheetFunction.Transpose(Range(Range("h2"), Range("h1").End(xlDown))), ",")
            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
                End If
            Next
            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] 单元格开始的区域中。
        
        　

        一、 问题的提出：
        有多列多行数据，其中有重复的行，要求编写一段代码，求得不重复的行数据。
        　
        二、代码 ：
        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("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 单元格开始的区域中。
        　

        一、 问题的提出：
        有一个表格，需要对其中多个条件相同的数量进行合并汇总，并且要有汇总的明细数据，要求编写一段代码，实现这样的合并同类项的要求。
        
        　
        二、代码 ：
        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
        三、代码详解
        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./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 开始的单元格区域。
        
        　

        一、 问题的提出：
        A 列 B 列是按顺序排列的全部股票代码和股票名称， C 列 D 列和 E 列 F 列是另外按条件筛选出来的无序的数据，     要求编写一段代码，将它们排列到与 A 列相同的股票行里面。
               　 　
        二、代码 ：
        Private Sub CommandButton1_Click()   'by:oobird
        Dim d As Object, rng, i%, j%, arr
        Set d = CreateObject("Scripting.Dictionary")
        rng = Range("a3:f" & [a65536].End(xlUp).Row)
        ReDim arr(1 To UBound(rng), 1 To 4)
        For i = 1 To UBound(rng)    
        d(CStr(rng(i, 1))) = 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("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 开始的单元格区域。
        
        　

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

        二、代码：
        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("Scripting.Dictionary")
        Myr =[b65536].End(xlUp).Row
        Arr = Range("a2:b" & 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, ",")(0)
        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 列，就会遗漏一些数据。
        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) 来表示。
        　

        一、问题的提出：
        要求编写一段代码，求得 B 列不重复的名字，其相应的 A 列和 D 列分别用 " " 连起来，而相应的 E 列 F 列的数值分别相加汇总。
        二、代码：
        Sub yy()  'by:Zamyi
        Dim d As New Dictionary, R
        Dim k, i&, j&
        R = Sheet1.UsedRange
        k = 1
        For i = 2 To UBound(R)
            R(i, 2) = Replace(Replace(R(i, 2), " （ ", "("), " ） ", ")")
            If d.Exists(R(i, 2)) Then
                R(d(R(i, 2)), 1) = R(d(R(i, 2)), 1) & " " & R(i, 1)
                R(d(R(i, 2)), 4) = R(d(R(i, 2)), 4) & " " & R(i, 4)
                R(d(R(i, 2)), 5) = Val(R(d(R(i, 2)), 5)) + R(i, 5)
                R(d(R(i, 2)), 6) = Val(R(d(R(i, 2)), 6)) + R(i, 6)
            Else
                k = k + 1
                d(R(i, 2)) = i
                For j = 1 To UBound(R, 2)
                    R(k, j) = R(i, j)
                Next
          End If
        Next
        With Sheet2
            .Cells.ClearContents
            .Cells.Borders.LineStyle = xlNone
            .[a1:F1].Resize(d.Count + 1) = R
            .[a1:F1].Resize(d.Count + 1).Borders.LineStyle = 1
        End With
        Set d = Nothing
        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 ：给这些单元格添加边框，线型为直线。
        　

        一、问题的提出：
        有 3 列数据，要求编写一段代码，如果 C 列名次、 A 列主排相同时，根据 B 列次排最大的只保留一行。
        解题思路：先对 3 列数据按主要关键字名次 _ 升序，次要关键字主排 _ 升序，第 3 关键字次排 _ 降序进行排序，然后运用字典，以”名次 | 主排” 作为关键字，它所在的行作为关键字的项加入字典，最后根据行引用相对的单元格值。
        　
        二、代码：
        Sub pmc()
        Dim i&, Myr&, Arr
        Dim d, x, rng
        Application.ScreenUpdating = False
        Set d = CreateObject("Scripting.Dictionary")
        Sheet1.Activate
        Myr = [a65536].End(xlUp).Row
        Range("A1:C" & Myr).Sort Key1:=Range("C2"), Order1:=xlAscending, Key2:=Range( _
                "A2"), Order2:=xlAscending, Key3:=Range("B2"), Order3:=xlDescending, _
                Header:=xlYes
        Arr = Range("a2:c" & 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("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 是一个单元格对象。
        　

        一、问题的提出：
        有如图实例 11-1 所示的工资表，要求编写一段代码，运用 VBA 自动生成 1 季度的工资表。
        解题思路：先把性别和姓名连起来作为关键字求得人员的不重复值，然后通过循环查找关键字获得其各月的工资，最后用 Replace 方法替换两列关键字区域得到各自的数据。
        代码执行前如图实例 11-1 所示。
        二、代码：
        Sub yy()
        Dim d, k, t, i&, j&, Arr, x, r1
        Set d = CreateObject("Scripting.Dictionary")
        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) <> "" 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 列中的性别替换掉，只留下姓名。
        　

        一、问题的提出 ：
        有一日报表，里面有生产型号、生产数量、返修原因、返修数量、报废原因、报废数量，要求编写一段代码，按同型号产品汇总生产数量；得到同型号产品相同返修原因的唯一值；按同型号产品相同返修原因汇总返修数量； 得到同型号产品相同报废原因的唯一值；同型号产品相同报废原因汇总报废数量，并且合并相同内容的单元格。
        二、代码：
        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("a3:g" & Myr)
        For i = 1 To UBound(Arr)
            x(1) = Arr(i, 2)
            d(1)(x(1)) = d(1)(x(1)) + Arr(i, 3)
            x(2) = Arr(i, 2) & "|" & Arr(i, 4)
            d(2)(x(2)) = d(2)(x(2)) + Arr(i, 5)
            x(3) = Arr(i, 2) & "|" & Arr(i, 4) & "|" & Arr(i, 6)
            d(3)(x(3)) = d(3)(x(3)) + Arr(i, 7)
        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("a3:k" & n).Sort Key1:=Range("b3"), Order1:=xlAscending, Key2:=Range("d3") _
                , Order2:=xlAscending, Key3:=Range("h3"), 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("a3:k" & 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) & "|" & 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 ：开启屏幕更新。
        　
        后语
        常见字典用法实例集锦到此告一段落了。字典就象一个二维数组 Arr(1 to n,1 to 2) ，不过它的第 2 维的最大上界为 2 ，相当于 2 列单元格，第 1 列存放的是关键字，这个关键字是除了数组以外的任何类型；第 2 列存放的是这个关键字对应的项，它可以是数据的任何类型。
        我收集的和接触到有关字典的实例的数量有限，一定会有更好更有代表性的实例没有接触到，希望有心人能提供出来，供大家学习分享。
        谢谢大家！