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

 实例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 编辑 ]