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

张雄友

感觉属于碰运气的办法，分一次班，要点几千次。代码有待修改。

yjh_27

张雄友 发表于 2014-7-24 22:40
感觉属于碰运气的办法，分一次班，要点几千次。代码有待修改。

代码确实有很大的改善空间
最起码不用点几千次是可以做到的，但这样长的运算时间又是个问题

yangyangzhifeng

张雄友 发表于 2014-7-24 22:40
感觉属于碰运气的办法，分一次班，要点几千次。代码有待修改。

只要理

1. Sub tt()
   
2.     Dim xb$, each_room_p&
   
3.     Range("e2:e65536").ClearContents
   
4.      each_room_p = Val(InputBox("定义多少人一间宿舍", "你想", 12))
   
5.     xb = "男"
   
6.     test xb, each_room_p
   
7.     xb = "女"
   
8.     test xb, each_room_p
   
9. End Sub
   
10. Sub test(ByVal xb$, ByVal each_room_p&)
    
11. '将学校按可安排的宿舍的盈余量升序排序，每次依此排序安排好一个宿舍
    
12. '当盈余量为0时，代表每次必须分配该校的学生
    
13. '当出现当盈余量<0的情况时，说明无法满足同宿舍没有来自同校的学生
    
14.     Dim ar, n&, i&, j&, k&, d, e, br(), cr(), x&, y&
    
15.     Set d = CreateObject("scripting.dictionary")
    
16.     Set e = CreateObject("scripting.dictionary")
    
17.     n = Range("a65536").End(3).Row
    
18.     ar = Range("a2:e" & n)
    
19.     For i = 1 To UBound(ar)
    
20.         If ar(i, 4) = xb Then
    
21.             If d(ar(i, 3)) = "" Then d(ar(i, 3)) = d.Count
    
22.             e(ar(i, 3)) = e(ar(i, 3)) + 1
    
23.         End If
    
24.     Next
    
25.     n = Application.Max(e.items)
    
26.     ReDim br(0 To n, 1 To d.Count), cr(1 To d.Count, 1 To 2)
    
27.     n = Application.RoundUp(Application.Sum(e.items) / each_room_p, 0)
    
28.     For i = 1 To UBound(ar)
    
29.         If ar(i, 4) = xb Then
    
30.             x = d(ar(i, 3))    '学校序号
    
31.             br(0, x) = br(0, x) + 1    '学校总人数
    
32.             br(br(0, x), x) = i    '记录学生的位置号
    
33.         End If
    
34.     Next
    
35.     For i = 1 To UBound(br, 2)
    
36.         cr(i, 1) = i: cr(i, 2) = n - br(0, i)
    
37.         If cr(i, 2) < 0 Then MsgBox xb & "生无法满足同宿舍人员来自不同学校": Exit Sub
    
38.     Next
    
39.     For i = 1 To n
    
40.         paixu cr
    
41.         For j = 1 To each_room_p
    
42. '            If (i - 1) * each_room_p + j > Application.Sum(e.items) Then Exit For
    
43.             x = br(0, cr(j, 1))
    
44.             y = br(x, cr(j, 1))
    
45.             If x = 0 Then Exit For
    
46.             ar(y, 5) = xb & "舍" & Format(i, "000")
    
47.             x = x - 1
    
48.             If x = 0 Then
    
49.                 cr(j, 2) = n
    
50.             End If
    
51.             br(0, cr(j, 1)) = x
    
52.         Next
    
53.         For k = j To UBound(cr)    '本轮未分配的学校，宿舍盈余-1
    
54.             cr(k, 2) = cr(k, 2) - 1
    
55.             If cr(k, 2) < 0 And i < n Then
    
56.                 MsgBox xb & "生无法满足同宿舍人员来自不同学校": Exit Sub
    
57.             End If
    
58.         Next
    
59.     Next
    
60.     Range("a2").Resize(UBound(ar), UBound(ar, 2)) = ar
    
61. End Sub
    
62. Sub paixu(t())
    
63.     Dim i&, j&, x
    
64.     For i = UBound(t) - 1 To 1 Step -1
    
65.         For j = 1 To i
    
66.             If t(j, 2) >= t(j + 1, 2) Then '不稳定排序以实现随机性
    
67.                 x = t(j, 2): t(j, 2) = t(j + 1, 2): t(j + 1, 2) = x
    
68.                 x = t(j, 1): t(j, 1) = t(j + 1, 1): t(j + 1, 1) = x
    
69.             End If
    
70.         Next
    
71.     Next
    
72. End Sub
    

复制代码

论上可以分配，就一定可以分好，要更好的随机性，可以将初始名单乱序后在运行

张雄友

yangyangzhifeng 发表于 2014-7-29 09:39
只要理论上可以分配，就一定可以分好，要更好的随机性，可以将初始名单乱序后在运行

如执行宏，输入14，就是每个宿舍住14人时，女生宿舍无法满足来自不同的学校。这个不能满足，是指个别宿舍无法满足的，但是个别宿舍还是可以满足的。能不能把可以满足的宿舍分出来，不能满足的就最后安排在一间宿舍？

yangyangzhifeng

张雄友 发表于 2014-7-29 18:41
如执行宏，输入14，就是每个宿舍住14人时，女生宿舍无法满足来自不同的学校。这个不能满足，是指个别宿舍 ...

If cr(i, 2) < 0 Then MsgBox xb & "生无法满足同宿舍人员来自不同学校": Exit Sub
改成
If cr(i, 2) < 0 Then MsgBox xb & "生无法满足同宿舍人员来自不同学校"

张雄友

yangyangzhifeng 发表于 2014-7-29 20:43
If cr(i, 2) < 0 Then MsgBox xb & "生无法满足同宿舍人员来自不同学校": Exit Sub
改成
If cr(i, 2) < ...

不对，有一个人无法安排。透视表验证是：9，1，应该是10 才对。
女舍006  9

空白       1


女舍006 为10才对。

yangyangzhifeng

张雄友 发表于 2014-7-29 20:55
不对，有一个人无法安排。透视表验证是：9，1，应该是10 才对。
女舍006  9

试试看

1. Sub yangyangzhifeng() 'http://club.excelhome.net/thread-895293-12-1.html
   
2. '只要理论上可以分配，就一定可以分好，要更好的随机性，可以将初始名单乱序后再运行！
   
3.     Dim xb$, each_room_p&
   
4. 
   
5.     Range("E2:E65536").ClearContents
   
6.      each_room_p = Val(InputBox("定义多少人一间宿舍", "你想", 14))
   
7.     xb = "男"
   
8.     test xb, each_room_p
   
9.     xb = "女"
   
10.     test xb, each_room_p
    
11.     ActiveSheet.PivotTables("数据透视表1").PivotCache.Refresh '刷新数据透视表
    
12. 
    
13. End Sub
    
14. Sub test(ByVal xb$, ByVal each_room_p&)
    
15. '将学校按可安排的宿舍的盈余量升序排序，每次依此排序安排好一个宿舍
    
16. '当盈余量为0时，代表每次必须分配该校的学生
    
17. '当出现当盈余量<0的情况时，说明无法满足同宿舍没有来自同校的学生
    
18.     Dim ar, n&, i&, j&, k&, d, e, br(), cr(), dr&(), x&, y&
    
19.     Set d = CreateObject("scripting.dictionary")
    
20.     Set e = CreateObject("scripting.dictionary")
    
21.     n = Range("A65536").End(3).Row
    
22.     ar = Range("A2:E" & n)    '！！！！！！！！！！！！！！！！！！！！！！！！！！！！！！！！！！！！！！！！！！！！！！！！！！！！！！
    
23.     For i = 1 To UBound(ar)
    
24.         If ar(i, 4) = xb Then    '第四列为性别！！！！！！！！！！！！！！！！！！！！！！！！！！！！！！！！！！！！！！！！！！！！！！！
    
25.             If d(ar(i, 3)) = "" Then d(ar(i, 3)) = d.Count    '对第三列进行不重复值设置！！！！！！！！！！！！！！！！！！！！！！！！！！
    
26.             e(ar(i, 3)) = e(ar(i, 3)) + 1    '累加变量！！！！！！！！！！！！！！！！！！！！！！！！！！！！！！！！！！！！！！！！！！！
    
27.         End If
    
28.     Next
    
29.     n = Application.Max(e.items)
    
30.     ReDim br(0 To n, 1 To d.Count), cr(1 To d.Count, 1 To 2)
    
31.     n = Application.RoundUp(Application.Sum(e.items) / each_room_p, 0)
    
32.     ReDim dr(1 To n)    '记录宿舍空位
    
33.     For i = 1 To UBound(ar)
    
34.         If ar(i, 4) = xb Then    '第四列为性别！！！！！！！！！！！！！！！！！！！！！！！！！！！！！！！！！！！！！！！！！！！！！！！
    
35.             x = d(ar(i, 3))    '学校序号！！！！！！！！！！！！！！！！！！！！！！！！！！！！！！！！！！！！！！！！！！！！！！！！
    
36.             br(0, x) = br(0, x) + 1    '学校总人数
    
37.             br(br(0, x), x) = i    '记录学生的位置号
    
38.         End If
    
39.     Next
    
40.     For i = 1 To UBound(br, 2)
    
41.         cr(i, 1) = i: cr(i, 2) = n - br(0, i)
    
42.         'If cr(i, 2) < 0 Then MsgBox xb & "生无法满足同宿舍人员来自不同学校": Exit Sub
    
43.         '如执行宏，输入14，就是每个宿舍住14人时，女生宿舍无法满足来自不同的学校。
    
44.         '这个不能满足，是指个别宿舍无法满足的，但是个别宿舍还是可以满足的，
    
45.         '能不能把可以满足的宿舍分出来，不能满足的就最后安排在一间宿舍？
    
46.         'If cr(i, 2) < 0 Then MsgBox xb & "生无法满足同宿舍人员来自不同学校": Exit Sub
    
47.         '改成
    
48.         If cr(i, 2) < 0 Then MsgBox xb & "生无法满足同宿舍人员来自不同学校"
    
49.     Next
    
50.     For i = 1 To n
    
51.         paixu cr
    
52.         For j = 1 To each_room_p
    
53.             x = br(0, cr(j, 1))
    
54.             y = br(x, cr(j, 1))
    
55.             If x = 0 Then dr(i) = each_room_p - j + 1: Exit For
    
56.             ar(y, 5) = xb & "舍" & Format(i, "000")    '在第五列生成宿舍号！！！！！！！！！！！！！！！！！！！！！！！！！！！！！！！！！
    
57.             x = x - 1
    
58.             If x = 0 Then
    
59.                 cr(j, 2) = n
    
60.             End If
    
61.             br(0, cr(j, 1)) = x
    
62.         Next
    
63.         For k = j To UBound(cr)    '本轮未分配的学校，宿舍盈余-1
    
64.             cr(k, 2) = cr(k, 2) - 1
    
65.         Next
    
66.     Next
    
67.     If Application.Sum(Application.Index(br, 1, 0)) > 0 Then
    
68.         i = 0: j = 0
    
69.         Do
    
70.             Do
    
71.                 i = i + 1
    
72.                 If br(0, i) > 0 Then x = br(0, i): Exit Do
    
73.                 If i = d.Count Then i = 0
    
74.             Loop
    
75.             Do
    
76.                 j = j + 1
    
77.                 If dr(j) > 0 Then Exit Do
    
78.             Loop
    
79.             ar(br(x, i), 5) = xb & "舍" & Format(j, "000")
    
80.             x = x - 1: br(0, i) = x
    
81.             If Application.Sum(Application.Index(br, 1, 0)) = 0 Then Exit Do
    
82.             j = j Mod n
    
83.             i = i Mod d.Count
    
84.         Loop
    
85.     End If
    
86.     Range("A2").Resize(UBound(ar), UBound(ar, 2)) = ar
    
87. End Sub
    
88. Sub paixu(t())
    
89.     Dim i&, j&, x
    
90.     For i = UBound(t) - 1 To 1 Step -1
    
91.         For j = 1 To i
    
92.             If t(j, 2) >= t(j + 1, 2) Then '不稳定排序以实现随机性
    
93.                 x = t(j, 2): t(j, 2) = t(j + 1, 2): t(j + 1, 2) = x
    
94.                 x = t(j, 1): t(j, 1) = t(j + 1, 1): t(j + 1, 1) = x
    
95.             End If
    
96.         Next
    
97.     Next
    
98. End Sub
    

复制代码

张雄友

yangyangzhifeng 发表于 2014-7-30 00:01
试试看

如执行宏，输入16，就是每个宿舍住16人时，这样男女都无法分配了。不正确，理论上，男女还是可以分配的。（113楼代码男生都可以分配）

yangyangzhifeng

张雄友 发表于 2014-7-30 06:44
如执行宏，输入16，就是每个宿舍住16人时，这样男女都无法分配了。不正确，理论上，男女还是可以分配的。 ...

117楼编辑过了，再试试看。因为你写了On error resume goto 语句,而代码有一处错误，所以造成没有输出。

张雄友

yangyangzhifeng 发表于 2014-7-30 07:06
117楼编辑过了，再试试看。因为你写了On error resume goto 语句,而代码有一处错误，所以造成没有输出。

是的，但是有个问题，如果执行，点取消时，会出现错误，除数为0，怎么不让这个对话框出现？