【烟花原创】VBA零基础之第144篇 字典（二十一）

hwc2ycy

四、实战

12．数组中存储字典（一）

这道题是VBA实战营的练习题，当时学艺未精，勉强混进了实战营，当时也没做出。某日在以前的字典班的课件里找到这题，这里借liuguansky的代码，我只写点注释。

数据源文件： 舞伴配对（数据）.rar (134.57 KB, 下载次数: 117)

2014-4-3 23:32 上传

点击文件名下载附件

数据截图：

实际数据一共有7000多行。

要求：

公司搭配舞伴，男女骰子点数和为7的互为舞伴。将每组舞伴写在E:F列，要求按舞伴里最早出现的人来排序。

思路：

由于员工的骰子点数只会在1到6点之前，所以定义了一个大数组Arr(1 to 6)来存储对应点数的数据。员工性别有男女之分，所以Arr中每一个元素中均存储了一个小数组arrt(1 to 2)。

接着，同一性别的不同员工点数会有相同的情况，所以在这个arrt小数组中分别存储了一个字典。字典的Key是员工的姓名，对应的Item是该员工在数据中的行号（题目要求按舞伴最早出现的人来排序）。

数组示意图：

代码：

810126769

老师辛苦了！
请问老师，后期绑定的字典能否嵌套使用？

hwc2ycy

810126769 发表于 2014-4-4 07:28
老师辛苦了！
请问老师，后期绑定的字典能否嵌套使用？

一样可以，嵌套跟前后期无关。

810126769

hwc2ycy 发表于 2014-4-4 08:41
一样可以，嵌套跟前后期无关。

如果是后期绑定的话，set arrt(1)=New Dictionary 会报错啊！

香川群子

本题用数组做也很容易，速度快一倍。

如果用字典，而不需要这么复杂……呵呵。

香川群子

先公布一下我的数组算法，有详细注释：

1. Sub kagawa()
   
2.     Dim arr, brr, crr, xrr, i&, j&, k&, m&, n&, s1&, s2&, t&, x$, tms#
   
3.     tms = Timer
   
4.     arr = [a1].CurrentRegion '源数据读入数组arr
   
5.     m = UBound(arr) '数据最大行数m
   
6.    
   
7.     ReDim xrr(m, 1) '创建记录姓名和序号的嵌套子数组xrr模板
   
8.     ReDim brr(1 To 6, 1 To 2) '定义与骰子点数对应的嵌套数组brr
   
9.     For i = 1 To 6 '对于各个骰子点数
   
10.         brr(i, 1) = xrr '男生记录数组初始化
    
11.         brr(i, 2) = xrr '女生记录数组初始化
    
12.     Next
    
13.    
    
14.     ReDim crr(1 To m, 1 To 3) '定义存储结果的数组crr
    
15.     For i = 2 To m '遍历循环各行
    
16.         If arr(i, 2) = "男" Then s1 = 1: s2 = 2 Else s1 = 2: s2 = 1
    
17.         '以s1/s2为性别参数 方便以后自动对准位置
    
18.         t = arr(i, 3) '读取当前骰子点数
    
19.         n = brr(7 - t, s2)(0, 0) + 1 '可配对点数7-t以及对应性别s2的读取位置n
    
20.         x = brr(7 - t, s2)(n, 0) '读取可配对位置信息 姓名x
    
21.         If x = "" Then '为空时不能配 则在当前性别s1的记录中存入当前信息
    
22.             n = brr(t, s1)(0, 1) + 1 '当前存入位置
    
23.             brr(t, s1)(0, 1) = n '存入位置记录n更新
    
24.             brr(t, s1)(n, 0) = arr(i, 1) '存入当前姓名
    
25.             brr(t, s1)(n, 1) = i '存入当前序号
    
26.         Else '可以配对时在对应性别s2中操作
    
27.             k = k + 1 '记录数组crr的行序号k + 1
    
28.             crr(k, s1) = arr(i, 1) '写入当前姓名
    
29.             crr(k, s2) = x         '写入配对者姓名x
    
30.             j = brr(7 - t, s2)(n, 1) '获取配对点数7-t及对应性别s2配对者序号j
    
31.             If i < j Then crr(k, 3) = i Else crr(k, 3) = j '取最小序号(最先出现者)
    
32.             brr(7 - t, s2)(0, 0) = n '可配对读取位置n下移
    
33.         End If
    
34.     Next
    
35.    
    
36.     Application.ScreenUpdating = False
    
37.     [i2].CurrentRegion.Offset(1) = "" '清空输出区域
    
38.     [i2].Resize(k, 3) = crr '计算结果写入工作表
    
39.     [i2].Resize(k, 3).Sort [k2], 1, , , , , , 2 '用工作表排序方法
    
40.     [k:k] = "" '清空排序辅助的序号信息
    
41.     Application.ScreenUpdating = True
    
42.    
    
43.     MsgBox Format(Timer - tms, "0.000s ") & k
    
44. End Sub

复制代码

我承认，用数组做比字典要难度大一点（思路更复杂一些）
但好处是速度一定更快。

再者说，和楼主的【复杂字典】用法相比较，反而或许是我的数组方法更容易理解了……。


…………
补充说明：
brr(i, 1) = xrr '男生记录数组初始化

我的嵌套数组xrr的格式是一个 0-m行、0-1共2列的二维数组

数组最大行数=m其实很浪费了。加入骰子点数和男、女人数比较均匀随机的话，
理论上取最大行数平均值=m/6/2，那么实际取 m/6一般也够了。
但为安全起见，闭着眼睛就全部用了m行。（这会浪费内存资源，如果实际运算有影响还是值得考虑减小行数）

接下来，这个xrr模板数组的用法其实特别地简单，起到了代替字典的作用：
brr(t,s1)(n,0) 即0列用来存储 姓名信息 即每次读入=arr(i,1)
brr(t,s1)(n,1) 即1列用来存储 对应序号 即每次读入= i  以便在最后排序时用
    (话说出这个题的人也略微有些变态，因为这个排序基本上是毫无意义的。但是对增加题目难度还是有作用。)

其次，最重要的，是：brr(t,s1)(0,0) 和 brr(t,s1)(0,1) 这二个参数的记录作用。
说穿了也很简单：
即    (0,0)用来记录当前骰子点数、性别的人的【当前可配对者】在xrr模板数组中的行位置 即【取值位置】
而    (0,1)用来记录当前骰子点数、性别的人的【当前需记录者】在xrr模板数组中的行位置 即【存入位置】

如此，就是我的嵌套数组的全部秘密了。

香川群子

接着是我的字典算法：

显然比楼主的更简明，速度也更快。

1. Sub kagawa1() '前期绑定
   
2.     Dim arr, brr, crr, xrr, i&, j&, k&, m&, n&, s1&, s2&, t&, x$, tms#
   
3.     tms = Timer
   
4.     arr = [a1].CurrentRegion
   
5.     m = UBound(arr)
   
6.    
   
7.     ReDim xrr(m, 1)
   
8.     ReDim brr(1 To 6, 1 To 2) As New Dictionary '前期绑定时
   
9. '    ReDim brr(1 To 6, 1 To 2) '后期绑定时
   
10.     For i = 1 To 6
    
11.         Set brr(i, 1) = New Dictionary '前期绑定时
    
12.         Set brr(i, 2) = New Dictionary '前期绑定时
    
13. '        Set brr(i, 1) = CreateObject("Scripting.Dictionary") '后期绑定时
    
14. '        Set brr(i, 2) = CreateObject("Scripting.Dictionary") '后期绑定时
    
15.     Next
    
16.    
    
17.     ReDim crr(1 To m, 1 To 3)
    
18.     For i = 2 To m
    
19.         If arr(i, 2) = "男" Then s1 = 1: s2 = 2 Else s1 = 2: s2 = 1
    
20.         t = arr(i, 3)
    
21.         If brr(7 - t, s2).Count Then '字典有值时能配
    
22.             k = k + 1
    
23.             crr(k, s1) = arr(i, 1)
    
24.             x = brr(7 - t, s2).Keys()(0)
    
25.             j = brr(7 - t, s2).Items()(0)
    
26.             crr(k, s2) = x
    
27.             If i < j Then crr(k, 3) = i Else crr(k, 3) = j
    
28.             brr(7 - t, s2).Remove x
    
29.         Else ' 字典为空时 则需存入当前信息
    
30.             brr(t, s1)(arr(i, 1)) = i
    
31.         End If
    
32.     Next
    
33.    
    
34.     Application.ScreenUpdating = False
    
35.     [i2].CurrentRegion.Offset(1) = ""
    
36.     [i2].Resize(k, 3) = crr
    
37.     [i2].Resize(k, 3).Sort [k2], 1, , , , , , 2
    
38.     [k:k] = ""
    
39.     Application.ScreenUpdating = True
    
40.    
    
41.     MsgBox Format(Timer - tms, "0.000s ") & k
    
42. End Sub

复制代码

又仔细看了一下楼主的字典算法过程……
本质上也是几乎一样的算法。
不过对字典结果引用的手法还有改进的余地。

估计也是因为这个原因，造成了速度上的拖沓……

香川群子

下面用法影响速度：
① ReDim Preserve arrR(1 To 3, 1 To t)

ReDim Preserve 方法不是免费的，
不过是把【重新定义数组，把数据搬过去】这样的工作【后台运行】一遍而已。

因此，一般情况下，直接定义一个大一点的数组是高效的方法。
(你跟我说内存只有512k不够……别开玩笑了，这都什么时代了……不用过分担心定义大数组耗用内存)

② a = .Keys: b = .Items

由于每次只需取用第一个字典信息，所以不需要把这个字典内容都读取为数组。

具体方法参见我的代码。


③ Set o = arr(ar(i, 3))(j)
    o.Add ar(i, 1), i

哪个老师教的？一定要这样做么？

字典赋值应该直接用 = 句式。
arr(ar(i, 3))(j)(ar(i, 1)) = i
这样就可以了。

当然差别是有的：= 赋值不会报错，而Add方法会在字典key已经存在时报错。

hwc2ycy

810126769 发表于 2014-4-4 08:56
如果是后期绑定的话，set arrt(1)=New Dictionary 会报错啊！

你说了是后期，就得把set arrt(1)=New Dictionay
改成set arrt(1)=createobject("scripting.dictionary")

810126769

hwc2ycy 发表于 2014-4-4 12:38
你说了是后期，就得把set arrt(1)=New Dictionay
改成set arrt(1)=createobject("scripting.dictionary" ...

哦，谢谢老师！终于弄懂了！