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

蓝桥玄霜 · 发表于 2010-10-24 20:04

实例10 先字典求得行后显示整行数据

一、问题的提出：

有3列数据，要求编写一段代码，如果C列名次、A列主排相同时，根据B列次排最大的只保留一行。

解题思路：先对3列数据按主要关键字名次_升序，次要关键字主排_升序，第3关键字次排_降序进行排序，然后运用字典，以”名次|主排” 作为关键字，它所在的行作为关键字的项加入字典，最后根据行引用相对的单元格值。

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

图实例10-1示例

二、代码：

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

[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

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是一个单元格对象。

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

表格附件在上一楼。

doc 文件在1楼。

蓝桥玄霜 · 发表于 2010-10-24 20:06

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

一、问题的提出：

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

图实例11-1示例

二、代码：

Sub yy()

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

Set d = CreateObject("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

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)

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

[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列中的性别替换掉，只留下姓名。

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

xrw63l97.rar (34.29 KB, 下载次数: 292)

蓝桥玄霜 · 发表于 2010-10-24 20:10

实例12 复杂报表汇总

一、问题的提出 ：

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

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

图实例12-1示例

二、代码：

Sub bbhz()

Dim i&, Myr&, x(1 To 3), Arr, n%, aa, j&, Arr1(), r%, Arr2(), r2%, r3%, Arr3()

Dim d(1 To 3) As New dictionary, k(1 To 3), t(1 To 3), js, ks, ii%, jj&, ks1, js1

Application.ScreenUpdating = False

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

Arr = Sheet1.Range("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)

k(i) = d(i).Keys

t(i) = d(i).Items

[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)

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

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

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

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

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

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

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

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)

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

Application.DisplayAlerts = True

Application.ScreenUpdating = True

End Sub

蓝桥玄霜 · 发表于 2010-10-24 20:17

三、代码详解

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

全文请到1楼下载。表格附件在上一楼。

迅岐同心 · 发表于 2010-10-25 11:01

太好了，收藏了，慢慢学习！

fjmxwrs · 发表于 2010-11-1 23:41

学习学习留脚印

xdwy81129 · 发表于 2010-11-2 16:35

感谢总结

收藏学习了[em01]

fjk7070 · 发表于 2010-11-2 20:10

很复杂，不是很懂。

gwfzh · 发表于 2010-11-5 15:34

谢谢蓝桥玄霜老师！但下载后压缩文件为什么不能重命名？

herelazy · 发表于 2010-11-23 13:51

好东西，先收藏

		自动登录	找回密码
密码			注册

[分享] 常见字典用法集锦及代码详解

实例10

实例10 先字典求得行后显示整行数据

实例11

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

实例12 后语

实例12 复杂报表汇总

回复：（蓝桥玄霜）常见字典用法集锦及代码详解

后语