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

三坛老窖 · 发表于 2012-7-23 12:30

我也写了一个，思路和上面各位有所不同。
运行结果遵循：占用宿舍最少；同舍中无校友这两条原则。
分配成功的条件是：同校生数量不大于最小宿舍数。
我测试过，即使在较为极端的情况下，也能获得满意的分配方案。【极端情况：几所学校的生源数量都接近或等于最小宿舍数】
有兴趣的朋友，不妨设计一些极端数据，检验一下。

Option Explicit
Public Type StudentInfo
No As Long
Name As String
School As String
End Type
Public Const RANDOM_COUNT As Long = 100 '随机化次数
Public Const DORM_COUNT As Long = 6 '核定宿舍人数
Sub 宿舍分配2()
Dim i&, j&, k&, iRow&, t#
Dim BoyCount&, GirlCount& '男、女生人数
Dim arrData '源数据
Dim arrBoy() As StudentInfo '男生信息
Dim arrGirl() As StudentInfo '女生信息
Dim uInfo As StudentInfo
t = Timer
iRow = Range("A" & Rows.Count).End(xlUp).Row
arrData = Range("A2:E" & iRow)
'统计男、女生人数
For i = 1 To UBound(arrData)
If arrData(i, 4) = "男" Then BoyCount = BoyCount + 1 Else GirlCount = GirlCount + 1
Next i
'创建男、女生信息数组
ReDim arrBoy(1 To BoyCount)
ReDim arrGirl(1 To GirlCount)
For i = 1 To UBound(arrData)
uInfo.No = i: uInfo.School = arrData(i, 3)
If arrData(i, 4) = "男" Then
j = j + 1: arrBoy(j) = uInfo
Else
k = k + 1: arrGirl(k) = uInfo
End If
Next i
'分配宿舍
If Not AllotDorm(arrData, arrBoy, "男舍-") Then MsgBox "男舍分配失败！": Exit Sub
If Not AllotDorm(arrData, arrGirl, "女舍-") Then MsgBox "女舍分配失败！": Exit Sub
Range("A2:E" & iRow) = arrData
刷新数据透视表
MsgBox "分配成功！耗时：" & Format(Timer - t, "0.0000s ")
End Sub
'---------------------------------------------------------------------------------------
'
'分配：按序提取一个学生，挨个宿舍查看，如果该宿舍人数小于DORM_COUNT人并无该生的校友，则
'分入该舍，接着提取下一名学生。否则查看下一个宿舍。如果所有宿舍都不满足分入该生的条件，
'则重新随机化学生的分配顺序，并重新分配。当随机化次数超过RANDOM_COUNT次时，宣布分配失败，
'并退出。
'---------------------------------------------------------------------------------------
Function AllotDorm(arrData, arrStudent() As StudentInfo, ByVal Sex As String) As Boolean
Dim i&, j&, k&, iCount&, Number&
Dim uInfo As StudentInfo
Dim arrDorm() '男舍，二维数组，第一维有两个单元，第一个单元用于统计宿舍人数，
'第二个单元用于存放分入该舍学生的母校信息；第二维代表宿舍号。
Number = UBound(arrStudent) '学生人数
Start:
ReDim arrDorm(1 To 2, 1 To Application.RoundUp(Number / DORM_COUNT, 0)) '创建宿舍
'随机化分配顺序
For i = 1 To Number
k = Int((Number - i + 1) * Rnd()) + i
uInfo = arrStudent(k): arrStudent(k) = arrStudent(i): arrStudent(i) = uInfo
Next i
'分配
For i = 1 To Number
For j = 1 To UBound(arrDorm, 2)
If arrDorm(1, j) < DORM_COUNT And InStr(1, arrDorm(2, j), arrStudent(i).School) = 0 Then
arrDorm(1, j) = arrDorm(1, j) + 1
arrDorm(2, j) = arrDorm(2, j) & arrStudent(i).School & ","
arrData(arrStudent(i).No, 5) = Sex & Format(j, "00")
Exit For
End If
Next j
If j > UBound(arrDorm, 2) Then
iCount = iCount + 1
If iCount < RANDOM_COUNT Then GoTo Start Else Exit Function
End If
Next i
AllotDorm = True
End Function
Sub 刷新数据透视表()
ActiveSheet.PivotTables("数据透视表2").PivotCache.Refresh
[I:aa].ColumnWidth = 3
End Sub

复制代码

宿舍分配.rar (29.06 KB, 下载次数: 32)

小花鹿 · 发表于 2012-7-23 13:01

三坛老窖发表于 2012-7-23 12:30
我也写了一个，思路和上面各位有所不同。
运行结果遵循：占用宿舍最少；同舍中无校友这两条原则。
分配成 ...

看不懂，能不能详细解释一下？

三坛老窖 · 发表于 2012-7-23 13:08

小花鹿发表于 2012-7-23 13:01
看不懂，能不能详细解释一下？

是总体思路看不懂，还是某条语句或语句块看不懂？

liucqa · 发表于 2012-7-23 13:27

我的思路是这样的：

1、编麻花，就是每个学校抽一个人，组成6个排序
2、排到后面会出现重复，将重复的人随机往前挪几个人的位置，直至检查没有重复学校的编在一起为止。

这个算法一般不会发生死机，但可能会慢一点。

小花鹿 · 发表于 2012-7-23 13:33

liucqa 发表于 2012-7-23 13:27
我的思路是这样的：

1、编麻花，就是每个学校抽一个人，组成6个排序

给个图看看呗。

小花鹿 · 发表于 2012-7-23 13:38

三坛老窖发表于 2012-7-23 13:08
是总体思路看不懂，还是某条语句或语句块看不懂？

每条语句没逐个看，暂时是总体思路不懂，另外我没用过自定义函数。

香川群子 · 发表于 2012-7-23 14:06

liucqa 发表于 2012-7-23 13:27
我的思路是这样的：

1、编麻花，就是每个学校抽一个人，组成6个排序

就这么个思路，到现实的代码之间，还有很多路要走……

并且，也许有很多问题、bug需要解决。

呵呵。

随机性如何保证，或如何体现，也是个疑问。

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

三坛老窖发表于 2012-7-23 12:30
我也写了一个，思路和上面各位有所不同。
运行结果遵循：占用宿舍最少；同舍中无校友这两条原则。
分配成 ...

我认为不应该偏题，
不能按照【小花鹿】自作主张增加的条件：【部分学校人数超多！】去考虑问题。

因为这样一来，同一宿舍中没有同校学生的条件就是发傻的行为。
（按实际情形也应该不会这样子的。）

因此，希望你回到主题，就用楼主的数据，
看如何编写代码，一次性随机抽取分配学生，保证除了零头都是6个学生一个宿舍，且没有同校学生。

香川群子 · 发表于 2012-7-23 14:16

目前，只有我写的代码，能够保证代码反复运行，

都能一次性得到具有充分随机性的分配方案，而不会死循环。

840205910 · 发表于 2012-7-23 15:30

zhaogang1960 发表于 2012-7-19 13:17
短信收到，请测试：

赵老师，你好！
请问，我想一次性把多列数据装进字典做关键词，并求和，不知道怎么用法，请赐教！如附件，我想一次性把多列数据装进字典做关键词，并求和，不知道怎么用法，请赐教！http://club.excelhome.net/thread-896860-1-1.html

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

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

点评