求助：怎么利用VBA实现排列组合，进行分组排序？谢谢！

香川群子 · 发表于 2012-7-20 23:25

本帖最后由香川群子于 2012-7-22 16:56 编辑

好吧，彻底满足小花鹿的要求。

其实，男生女生的代码几乎完全相同，不过是在过程中复制一下而已。

附件中最后还有数据透视表作结果验证。

整个代码运行0.1秒不到。

附件更新，解决了bug

宿舍分配3.rar (26.88 KB, 下载次数: 75)

香川群子 · 发表于 2012-7-20 23:28

本帖最后由香川群子于 2012-7-22 16:45 编辑

小花鹿发表于 2012-7-20 21:32
学校和性别乱序都是有可能的，比如这个表是按学生报名时的顺序填写的，而分宿舍时又不想打乱这个顺序。

完整代码，已经做了注释。

希望小花鹿能看懂。

Sub kagawa()
Dim i%, j%, k%, m%, n%
tms = Timer '代码运行计时开始
Randomize '随机种子初始化
m = [a1].End(4).Row - 1 '获取原始数据最大行数
[e2].Resize(m) = "" '清空上次配对结果
arr = [a2].Resize(m, 5) '获取原始数据
Set dx_rs = CreateObject("Scripting.Dictionary") '定义女生人数字典各校剩余未抽人数[校名/女生人数]
Set dx_xh = CreateObject("Scripting.Dictionary") '定义女生序号字典 [序号/序号_女生校名]
Set dy_rs = CreateObject("Scripting.Dictionary") '定义男生人数字典各校剩余未抽人数[校名/男生人数]
Set dy_xh = CreateObject("Scripting.Dictionary") '定义男生序号字典 [序号/序号_男生校名]
For i = 1 To m
If arr(i, 4) = "女" Then
dx_rs(arr(i, 3)) = dx_rs(arr(i, 3)) + 1 '女生校名人数加总
dx_xh(CStr(i)) = i & " " & arr(i, 3) '女生序号_校名对应
Else
dy_rs(arr(i, 3)) = dy_rs(arr(i, 3)) + 1 '男生校名人数加总
dy_xh(CStr(i)) = i & " " & arr(i, 3) '男生序号_校名对应
End If
Next
Dim a(5) '定义数组a存放每个宿舍中已经抽取校名
For i = (dx_xh.Count - 1) \ 6 + 1 To 2 Step -1 '按女生所需宿舍数循环抽取
For j = 0 To 5
p = dx_rs.keys '每次重新获取剩余人数的校名key到数组p
q = dx_rs.items '每次重新获取剩余各校人数item到数组q
For k = 0 To dx_rs.Count - 1 '遍历检查各校剩余人数情况
If q(k) = i Then '如果该校剩余人数等于待分配宿舍数
s = Filter(dx_xh.items, p(k), True) '则必须强制从该校中先抽取1人，否则会造成死循环。
GoTo xDraw '学校甄别完成后，直接跳到女生随机抽取处理过程
End If
Next
For k = 0 To dx_rs.Count - 1 '遍历检查各校剩余人数情况
If q(k) = i - 1 Then '如果该校剩余人数等于待分配宿舍数-机动1
s = Filter(dx_xh.items, p(k), True) '则必须强制从该校中先抽取1人，否则会造成死循环。
GoTo xDraw '学校甄别完成后，直接跳到女生随机抽取处理过程
End If
Next
s = dx_xh.items '如果都没有剩余人数等于待分宿舍数而必须强制抽取的学校
For k = 0 To j - 1 '遍历数组a中本次已经抽取学校
s = Filter(s, a(k), False) '过滤去除该校。
Next
xDraw:
r = Int(Rnd() * (UBound(s) + 1)) '按已经过滤的数组s人数进行随机抽取。
xh = Split(s(r))(0): dx_xh.Remove (xh) '根据随机数r从数组s中获取[序号_校名]的第1项序号信息，并从字典中删除该序号及对应信息
xm = Split(s(r))(1): a(j) = xm: If dx_rs(xm) = 1 Then dx_rs.Remove (xm) Else dx_rs(xm) = dx_rs(xm) - 1 '各校剩余人数字典更新
arr(xh, 5) = "女舍_" & Right("00" & i, 3) '对应抽取结果写入数组
' [a2].Resize(m, 5) = arr '调试程序时显示输出结果
Next
Next
s = dx_xh.items '字典dx_xh中剩余最后几个人的item即[序号_校名]读入数组s
For j = 0 To UBound(s)
xh = Split(s(j))(0) '获取[序号_校名]的第1项序号信息，
arr(xh, 5) = "女舍_001" '对应序号抽取结果写入数组
' [a2].Resize(m, 5) = arr '调试程序时显示输出结果
Next
' [a2].Resize(m, 5) = arr '最终输出结果
' MsgBox Format(Timer - tms, "0.0000s ") '输出代码运行时间。
For i = (dy_xh.Count - 1) \ 6 + 1 To 2 Step -1 '按男生所需宿舍数循环抽取
For j = 0 To 5
p = dy_rs.keys '每次重新获取剩余人数的校名key到数组p
q = dy_rs.items '每次重新获取剩余各校人数item到数组q
For k = 0 To dy_rs.Count - 1 '遍历检查各校剩余人数情况
If q(k) = i Then '如果该校剩余人数等于待分配宿舍数
s = Filter(dy_xh.items, p(k), True) '则必须强制从该校中先抽取1人，否则会造成死循环。
GoTo yDraw '学校甄别完成后，直接跳到男生随机抽取处理过程
End If
Next
For k = 0 To dy_rs.Count - 1 '遍历检查各校剩余人数情况
If q(k) = i - 1 Then '如果该校剩余人数等于待分配宿舍数-机动1
s = Filter(dy_xh.items, p(k), True) '则必须强制从该校中先抽取1人，否则会造成死循环。
GoTo yDraw '学校甄别完成后，直接跳到男生随机抽取处理过程
End If
Next
s = dy_xh.items '如果都没有剩余人数等于待分宿舍数而必须强制抽取的学校
For k = 0 To j - 1 '遍历数组a中本次已经抽取学校
s = Filter(s, a(k), False) '过滤去除该校。
Next
yDraw:
r = Int(Rnd() * (UBound(s) + 1)) '按已经过滤的数组s人数进行随机抽取。
xh = Split(s(r))(0): dy_xh.Remove (xh) '根据随机数r从数组s中获取[序号_校名]的第1项序号信息，并从字典中删除该序号及对应信息
xm = Split(s(r))(1): a(j) = xm: If dy_rs(xm) = 1 Then dy_rs.Remove (xm) Else dy_rs(xm) = dy_rs(xm) - 1 '各校剩余人数字典更新
arr(xh, 5) = "男舍_" & Right("00" & i, 3) '对应抽取结果写入数组
' [a2].Resize(m, 5) = arr '调试程序时显示输出结果
Next
Next
s = dy_xh.items '字典dx_xh中剩余最后几个人的item即[序号_校名]读入数组s
For j = 0 To UBound(s)
xh = Split(s(j))(0) '获取[序号_校名]的第1项序号信息，
arr(xh, 5) = "男舍_001" '对应序号抽取结果写入数组
' [a2].Resize(m, 5) = arr '调试程序时显示输出结果
Next
[a2].Resize(m, 5) = arr '最终输出结果
MsgBox Format(Timer - tms, "0.0000s ") '输出代码运行时间。
ActiveSheet.PivotTables("数据透视表1").PivotCache.Refresh
[h:aa].ColumnWidth = 3
End Sub

复制代码

代码中，防止死循环部分，提前强制抽取加了分级，效果好多了。
已经做了1万次模拟，没有bug了。

小花鹿 · 发表于 2012-7-20 23:53

香川群子发表于 2012-7-20 23:28
完整代码，已经做了注释。

希望小花鹿能看懂。不知道多次运行后有没有bug

谢谢，明天认真分析，希望能总结出一个此类问题的典型解法。

香川群子 · 发表于 2012-7-21 00:01

本帖最后由香川群子于 2012-7-22 16:57 编辑

刚刚做了测试，发现确实还有bug……到倒数第2宿舍分配时，有时会产生重复错误。

解决方法，是强制抽取的参数进行机动调整，加大提前量。

请看新的附件。后来再测试1万次，完全没有问题了。

…………如果还有担心，则可把机动参数再增加1个。呵呵。

最后的改正版如下，对于为了防止死循环而提前抽取的做法，加了一层优先级。

小花鹿 · 发表于 2012-7-21 23:59

由于我自己思维方式的问题，实在看不懂上面各位高手的代码（实际是天太热静不下心来），只好自己写了。
对于这个问题，我第一感觉就是先把原始数据进行重组，使之同校的学生处于同一行中（附件表3的效果），然后按列进行每6人一组的选取，但是，这时存在两个问题，一个是随机的问题，二个是按列选取时最后一组会有重复。
第一个问题的解决是听取了版主的意见，先生成随机不重复的数组，然后把原始数据打乱。
第二个问题费了很长时间，最后增加了一个数组存放学校名称，用字典进行判断。
最终效果见附件表2。
本来认为近百行的代码会很慢，没想到却飞快，看来还是用数组解决问题好，怪不得群子那么喜欢用数组。
Sub test2()
Dim ar1, ar2, xx(), cr(), br(), xb, r&, i&, j&, k&, x&, n&, m&, mc&, s, d, d1, t
t = Timer
Set d = CreateObject("scripting.dictionary")
Set d1 = CreateObject("scripting.dictionary")
ar1 = Sheet1.[a1].CurrentRegion
ar2 = ar1
r = UBound(ar1)
ReDim cr(2 To r)
For i = 2 To r
cr(i) = i
Next i
For i = 2 To r
n = Int(Rnd() * (r - i + 1)) + i
s = cr(i)
cr(i) = cr(n)
cr(n) = s
Next i
For i = 2 To r
For j = 1 To 4
      ar2(i, j) = ar1(cr(i), j)
Next j
Next i
xb = Array("男", "女")
ReDim br(1 To r, 1 To 8)
For k = 0 To 1
n = 0
ReDim ar1(1 To r, 1 To r)
ReDim xx(1 To r, 1 To r)
ReDim cr(1 To r)
For i = 2 To r
      s = ar2(i, 3)
      If ar2(i, 4) = xb(k) Then
         If d.exists(s) = 0 Then
            n = n + 1
            d(s) = n
            ar1(n, 1) = s & ar2(i, 2)
            xx(n, 1) = s
            cr(n) = 1
         Else
            cr(d(s)) = cr(d(s)) + 1
            ar1(d(s), cr(d(s))) = s & ar2(i, 2)
            xx(d(s), cr(d(s))) = s
            If mc < cr(d(s)) Then mc = cr(d(s))
         End If
      End If
Next i
d.RemoveAll
For j = 1 To mc
      For i = 1 To n
         If ar1(i, j) <> "" Then
            If d.Count = 6 Or d1.exists(xx(i, j)) Then
                  m = m + 1
                  s = d.keys
                  br(m, 1) = "宿舍" & m
                  br(m, 2) = xb(k)
                  For x = 0 To UBound(s)
                     br(m, x + 3) = s(x)
                  Next x
                  d.RemoveAll
                  d1.RemoveAll
            End If
            d(ar1(i, j)) = ""
            d1(xx(i, j)) = ""
         End If
      Next i
Next j
If d.Count Then
      m = m + 1
      s = d.keys
      br(m, 1) = "宿舍" & m
      br(m, 2) = xb(k)
      For x = 0 To UBound(s)
         br(m, x + 3) = s(x)
      Next x
      d.RemoveAll
      d1.RemoveAll
End If
Next k
Sheet2.[a1].Resize(m, 8) = br
MsgBox Format(Timer - t, "0.000")
End Sub

香川群子 · 发表于 2012-7-22 08:37

本帖最后由香川群子于 2012-7-22 08:42 编辑

小花鹿发表于 2012-7-21 23:59
由于我自己思维方式的问题，实在看不懂上面各位高手的代码（实际是天太热静不下心来），只好自己写了。
对 ...

不客气地说，你的代码是废的，没有用。

随机不重复的要求是达到了，
但你只是把最后几个重复的人，一人一个宿舍分开而已。

没有保证每6个人分一个宿舍。（只允许一个宿舍有不足6人的零头）

呵呵。

宿舍分配失败.jpg

看上图结果，尤其是女生宿舍，都分成什么样了……

你这样不过是鸵鸟把头埋在沙子里，有问题装看不见而已。楼主的要求根本没满足。

…………
还是要用我的方法。

香川群子 · 发表于 2012-7-22 10:25

本帖最后由香川群子于 2012-7-22 10:31 编辑

zhaogang1960 发表于 2012-7-19 17:46
请看附件

第2版比第1版好多了，不会死循环。

但是，偶尔还是会出现倒数第2个宿舍无法分配6人的情形。
（即最后剩余3人，和倒数第2宿舍中都有重复，已经无法分配进去。→实际上仍然是一种死循环现象）
宿舍分配赵刚.jpg

因此，本质上这个代码也不算成功。

宿舍分配赵刚.rar (26.49 KB, 下载次数: 15)

……
另外发现一个小bug，男生女生的第1位同学没有参与随机分配，总是被分在1号宿舍。

呵呵。

zhaogang1960 · 发表于 2012-7-22 11:16

本帖最后由 zhaogang1960 于 2012-7-22 11:17 编辑

香川群子发表于 2012-7-22 10:25
第2版比第1版好多了，不会死循环。

确有Bug，某些排序会出现找不出6个不同的学校，看来此法不通，加一个判断，如果出现这种情况，一切推倒重来，请看附件
第二个问题是群子在排序语句中加了Header:=xlYes所致，去掉就好了

宿舍分配222rr.rar (19.74 KB, 下载次数: 20)

小花鹿 · 发表于 2012-7-22 12:40

zhaogang1960 发表于 2012-7-19 17:46
请看附件

多次运行还是有重复：

zhaogang1960 · 发表于 2012-7-22 12:48

小花鹿发表于 2012-7-22 12:40
多次运行还是有重复：

幸亏楼主给出的数据比较合理，如果数据大多数来自一个学校，该程序根本就无法运行，能把重复数据放到最后一组，全凭了楼主的数据好啊

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

[求助] 求助：怎么利用VBA实现排列组合，进行分组排序？谢谢！

评分

评分