[已解决]请教一段代码，好象难了点

zpcs32

回复 zjdh 的帖子

zjdh解释的这四条真好！是位非常棒的老师！既解决了实际存在的问题，又解决了头脑中比较模糊的想法！真诚地感谢!

香川群子

目前的最佳答案并非最佳。

理由是：
1. 没有使用数组储存结果然后写入工作表，而是直接操作单元格写入结果。

这样做效率较低，速度较慢，不是好的习惯。

2. 每次随机抽取时，无法避免抽到已经抽过的人。
目前是用检查比对的方法处理，如果判断抽我们到重复，就再抽一次……

显然这样做效率更低了……
我们需要的是，保证每次抽取随机，但又绝对不会重复，也不会遗漏的算法。

我的代码中使用了经典的数组置换序号洗牌法（或称抽牌法）
效果是很好的。

3. 无法避免随机抽到最后，结果剩下的选手都是一个学校的……

目前做法是：
如果抽来抽取，比如抽了100次还是错误（即发生选手同校错误），
则让整个抽取过程重新来过。……

这个虽然也算是一种方法，尤其是后台操作不至于被人看到，
但这么做，简直是个笑话。是很低级的做法。


…………

请看我的附件。

代码虽然相对复杂，但执行效率高。

1. 抽取次数只要n-2次，不需要多余的重复抽取。
2. 保证不会有重复和遗漏。保证每次抽取是完全随机的。

呵呵。

香川群子

发表带详细注释的代码：

1. Sub test()
   
2.     Randomize '随机种子初始化
   
3.     tms = Timer '计时开始
   
4.    
   
5.     n = Sheets(2).[a1].End(4).Row - 1 '获取原始数据最大行数
   
6.     arr = Sheets(2).[a2].Resize(n, 2) '获取原始数据(选手名字和学校名)
   
7.    
   
8.     Set ds = CreateObject("Scripting.Dictionary") '定义字典ds（school）key存放每个学校名，item存放选手人数
   
9.     Set dn = CreateObject("Scripting.Dictionary") '定义字典dn（name & school）key存放每个选手姓名和学校名，item存放序号
   
10.    
    
11.     For i = 1 To n
    
12.         ds(arr(i, 2)) = ds(arr(i, 2)) + 1 '每个[学校名]对应item存放选手人数+1
    
13.         dn(arr(i, 2) & "_" & arr(i, 1)) = i '每个[学校名_选手名]对应item存放序号(初始行号)
    
14.     Next
    
15.         
    
16.    
    
17.     For i = n To 4 Step -2 '循环抽取，每次随机取2名选手，抽到i=4时剩余4人，抽完后只剩最后2人一组不用再抽了即可停止。
    
18.         
    
19.         If t <> "" Then GoTo half_jump '如果已经出现剩余人数最多学校人数=剩余人数的一半，即可进入半数单抽过程。
    
20.         
    
21.         q = ds.items '每次获取剩余各学校选手人数的数组
    
22.         l = WorksheetFunction.Large(q, 1) '获取其中剩余人数最多的学校的人数
    
23.         
    
24.         If l < i / 2 Then  '如果剩余人数最多学校的人数小于待抽取人数的一半，则不用担心下一轮回有死循环。
    
25.         '(简单说，如果某个学校剩余人数超过剩余待抽选手人数的一半，则无论如何抽，最后必定会有该学校选手对阵的错误结果。)
    
26.             
    
27.             '实际随机抽取方法，用了经典的数组倒序洗牌法。
    
28.             
    
29.             r = Int(Rnd() * i + 1) '从待抽人数中随机抽1个序号r
    
30.             
    
31.             t1 = arr(r, 1): t2 = arr(r, 2) '抽中的选手信息先存入中间变量t1、t2
    
32.             
    
33.             arr(r, 1) = arr(i, 1): arr(r, 2) = arr(i, 2) '把当前待抽选手中最后一个(数组i行)的内容，置换放入被抽中的数组序号r行中
    
34.             dn(arr(i, 2) & "_" & arr(i, 1)) = r '置换后的该[学校名_选手名]对应的数组序号也要从i行改正为序号r行
    
35.             
    
36.             arr(i, 1) = t1: arr(i, 2) = t2 '最后存放在中间变量中的本次抽中的选手信息，压栈放入当前最后1行(数组i行)中，完成对调。
    
37.             
    
38.             '这样就完成了一次随机抽取过程，不仅保证每一次的随机性，并能保证不重复、不遗漏。
    
39.             
    
40.             ds(t2) = ds(t2) - 1 '[学校/人数]字典ds中，把已经抽中选手的对应学校人数-1
    
41.             If ds(t2) = 0 Then ds.Remove (t2) '如果该学校剩余人数=0，则可从[学校/人数]字典ds中删去该学校了。
    
42.             
    
43.             dn.Remove (t2 & "_" & t1) '[学校选手/序号]字典dn中，删除已经抽中选手的信息
    
44.             
    
45.             s = dn.keys '获取剩余的所有[学校_选手]信息。(即删除了已抽中选手信息的新的[学校选手/序号]字典dn的keys)
    
46.             s = Filter(s, t2, False) '用Filter函数过滤去除和刚刚抽取过选手学校相同的所有选手，以保证接下来的抽取不会抽到相同学校选手。
    
47.             
    
48.             
    
49.             
    
50.             '下面是用完全相同的，经典的数组倒序洗牌法，抽取和刚才已经抽中的选手不同学校的选手。
    
51.             
    
52.             r1 = Int(Rnd() * (UBound(s) + 1)) '按已经过滤的数组s人数进行随机抽取。(因为s数组下标为0，因此相应人数要+1)
    
53.             r2 = dn(s(r1)) '先用s数组返回随机抽到r1对应的[学校_选手名]，接着用字典dn返回该学校该选手对应的数组更新序号。
    
54.             
    
55.             t1 = arr(r2, 1): t2 = arr(r2, 2) '抽中的选手信息先存入中间变量t1、t2
    
56.             
    
57.             arr(r2, 1) = arr(i - 1, 1): arr(r2, 2) = arr(i - 1, 2) '把当前待抽选手中最后一个(数组i-1行)的内容，置换放入被抽中的数组序号r2行中
    
58.             dn(arr(i - 1, 2) & "_" & arr(i - 1, 1)) = r2 '置换后的该[学校名_选手名]对应的数组序号也要从i-1行改正为序号r2行
    
59.             
    
60.             arr(i - 1, 1) = t1: arr(i - 1, 2) = t2 '最后存放在中间变量中的本次抽中的选手信息，压栈放入当前最后1行(数组i-1行)中，完成对调。
    
61.             
    
62.             ds(t2) = ds(t2) - 1 '[学校/人数]字典ds中，把已经抽中选手的对应学校人数-1
    
63.             If ds(t2) = 0 Then ds.Remove (t2) '如果该学校剩余人数=0，则可从[学校/人数]字典ds中删去该学校了。
    
64.             
    
65.             dn.Remove (t2 & "_" & t1) '[学校选手/序号]字典dn中，删除已经抽中选手的信息
    
66.             
    
67.         Else
    
68.         '如果剩余人数最多学校的人数已经=待抽取人数的一半时，则以后每一次抽取必须先抽这个学校的学生，然后再抽其他学校的。
    
69.         '否则，必定会产生该学校选手相互对阵的错误结果，进入死循环。
    
70.         
    
71.             For j = 0 To UBound(q)
    
72.                 If q(j) = l Then Exit For '检查剩余人数数组，直至找到那个人数最多的对应序号j
    
73.             Next
    
74.             p = ds.keys '获取[学校/人数]字典ds的keys数组，即返回剩余学校名称数组p
    
75.             t = p(j) '根据这个人数最多学校对应序号j，由[学校/人数]字典ds返回该学校名称
    
76. half_jump:
    
77.             s = dn.keys '获取剩余的所有[学校_选手]信息。(即删除了已抽中选手信息的新的[学校选手/序号]字典dn的keys)
    
78.             s = Filter(s, t, True) '用Filter函数过滤，保证只在该剩余人数最多学校中抽取1人。
    
79.             
    
80.             r1 = Int(Rnd() * (UBound(s) + 1)) '按已经过滤的该学校数组人数进行随机抽取。(因为s数组下标为0，因此相应人数要+1)
    
81.             r2 = dn(s(r1)) '先用s数组返回随机抽到r1对应的[学校_选手名]，接着用字典dn返回该学校该选手对应的数组更新序号。
    
82.             
    
83.             t1 = arr(r2, 1): t2 = arr(r2, 2) '抽中的选手信息先存入中间变量t1、t2
    
84.             
    
85.             arr(r2, 1) = arr(i, 1): arr(r2, 2) = arr(i, 2) '把当前待抽选手中最后一个(数组i行)的内容，置换放入被抽中的数组序号r2行中
    
86.             dn(arr(i, 2) & "_" & arr(i, 1)) = r2 '置换后的该[学校名_选手名]对应的数组序号也要从i行改正为序号r2行
    
87.             
    
88.             arr(i, 1) = t1: arr(i, 2) = t2 '最后存放在中间变量中的本次抽中的选手信息，压栈放入当前最后1行(数组i行)中，完成对调。
    
89.             
    
90.             dn.Remove (t2 & "_" & t1) '[学校选手/序号]字典dn中，删除已经抽中选手的信息
    
91.             
    
92.             
    
93.             
    
94.             '下面是用完全相同的，经典的数组倒序洗牌法，抽取和刚才已经抽中的选手不同学校的选手。
    
95.                         
    
96.             s = dn.keys '重新获取剩余的其他所有[学校_选手]信息。(即删除了已抽中选手信息的新的[学校选手/序号]字典dn的keys)
    
97.             s = Filter(s, t, False) '用Filter函数过滤，保证只在除去该剩余人数最多学校的其他学校选手中抽取1人。
    
98.             
    
99.             r1 = Int(Rnd() * (UBound(s) + 1)) '按已经过滤的数组s人数进行随机抽取。(因为s数组下标为0，因此相应人数要+1)
    
100.             r2 = dn(s(r1)) '先用s数组返回随机抽到r1对应的[学校_选手名]，接着用字典dn返回该学校该选手对应的数组更新序号。
     
101.             
     
102.             t1 = arr(r2, 1): t2 = arr(r2, 2) '抽中的选手信息先存入中间变量t1、t2
     
103.             
     
104.             arr(r2, 1) = arr(i - 1, 1): arr(r2, 2) = arr(i - 1, 2) '把当前待抽选手中最后一个(数组i-1行)的内容，置换放入被抽中的数组序号r2行中
     
105.             dn(arr(i - 1, 2) & "_" & arr(i - 1, 1)) = r2 '置换后的该[学校名_选手名]对应的数组序号也要从i-1行改正为序号r2行
     
106.             
     
107.             arr(i - 1, 1) = t1: arr(i - 1, 2) = t2 '最后存放在中间变量中的本次抽中的选手信息，压栈放入当前最后1行(数组i-1行)中，完成对调。
     
108.             
     
109.             dn.Remove (t2 & "_" & t1) '[学校选手/序号]字典dn中，删除已经抽中选手的信息
     
110.             
     
111.         End If
     
112.     Next
     
113.    
     
114.     '下面为整理已经全部随机抽取完成的数组arr结果，改为可以直接输出的形式。
     
115.     ReDim brr(n / 2 * 3, 1) '定义输出结果数组brr，每一对选手隔开一行。
     
116.     For i = 1 To n / 2 '遍历数组arr
     
117.         brr(i * 3 - 3, 0) = arr(i * 2 - 1, 2) '当前第1行第1列放入学校名
     
118.         brr(i * 3 - 3, 1) = arr(i * 2 - 1, 1) '当前第1行第2列放入选手名
     
119.         brr(i * 3 - 2, 0) = arr(i * 2, 2) '当前第2行第1列放入配对选手学校名
     
120.         brr(i * 3 - 2, 1) = arr(i * 2, 1) '当前第2行第2列放入配对选手名
     
121.     Next
     
122.     [a5].Resize(n / 2 * 3, 2) = brr '输出结果
     
123.     If t <> "" Then t = t & "(" & l & ")"
     
124.     MsgBox Format(Timer - tms, "0.0000s ") & t '输出代码运行时间，以及最后剩余人数超半数信息。
     
125.    
     
126. End Sub

复制代码

香川群子

原理如下：

准备工作：
1. 建立各学校，及其对应剩余选手人数的字典，以方便检查剩余人数，保证剩余人数不会有同校。
2. 建立各选手/学校名，及其对应数组序号的字典，以保证每次抽取不会发生同校。

接着开始随机抽取：
1. 用rand函数随机抽取1名选手。
2. 用洗牌法保证剩余人数中，不重复、无遗漏，以及保证每次都能完全随机。
3. 用filter函数排除同校以后，用洗牌法随机抽取与其配对的选手。

4. 检查各校剩余人数，是否有=总剩余人数的半数。
如果有，则今后开始每次都先随机抽该学校剩余选手一名，然后抽其他学校一名配对。
如果无，则继续采用前述随机抽取过程，而不用限定其中一名选手的学校了。

5. 遍历循环，直至剩余2人一组时可停止。（实际抽到i=4后结束）

6. 整理数组结果，改为楼主要求输出形式，然后输出。

以上。

香川群子

zjdh 发表于 2011-10-30 08:56
1.
       If I = N - 1 Then                        
            For j = 1 To N

数组不能删除……

因此一般是可以赋值为空，或=1来做检查。


但是，实际上数组也是可以删除数据的，但是有一些限制条件：

1. 必须是一维数组。
2. 只能用filter函数进行关键词的含有/不含有过滤方法，得到一个新的数组。
如：

1. 
   
2. Sub test3()
   
3.     ReDim a(9)
   
4.     For i = 0 To 9
   
5.         If i Mod 2 = 0 Then a(i) = "+" & i Else a(i) = i
   
6.     Next
   
7.     t = Filter(a, "+", False)
   
8.     t = Filter(a, "+", True)
   
9.     t = Filter(a, 1, False)
   
10.     t = Filter(a, 1, True)
    
11. End Sub

复制代码

至于字典，可以删除key，语法是：
d.remove (“key”)


除了字典以外，集合也可以删除，但只能事先知道索引以后，删除已知索引对应值：
s. remove (Index)



呵呵。

上清宫主

欢迎群子大大！
对于“最佳”，就是两个汉字而已，不必着相

zjdh

香川群子 发表于 2011-12-24 22:52
目前的最佳答案并非最佳。

理由是：

1. 楼主要的是羽毛球对决名单，肯定不会人数庞大，直接写入工作表影响速度并不是问题，更何况楼主9楼还提出要求一直循环！
2. 鉴于以上情况用最简单的语句解决简单的问题！
3. 若你看完了全部帖子应该知道，让整个抽取过程重新来过，是发展过来的，既然可以解决问题，为何不可用？？！！只用不到你的语句数的一个零头就解决了问题，何必再扬扬大篇从头再来？
4. 你1个最佳也没有，你想要最佳，给你也无妨！
5. 简单的问题复杂化，不是我想做的！稍微复杂一点的东西我也有，请看看我的帖子
http://club.excelhome.net/thread-704886-1-1.html
6. 至于你25楼说的东西，我早就用过，只是不想让语句复杂化！
7. 最佳只是相对的，在你这“才子”未出世前帖子已经解决了，没人解答挂了3天的求助，楼主最后评价是他的权力！

香川群子

好吧。既然你自己很满足，我也没有意见。

代码简单有效，就是最好。就是这个意思吧，大学一年级的朋友。


反而是我幼儿园小班的同学想复杂了。呵呵。