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

zhaogang1960 · 发表于 2012-7-19 16:19

本帖最后由 zhaogang1960 于 2012-7-19 16:44 编辑

小花鹿发表于 2012-7-19 14:38
不断重复运行程序，有时候会处于没有响应状态，不知什么原因？

字典+do循环就有这个问题，可以考虑使用数组解决，现在除了再使用字典+do循环，我还找不到每个宿舍中学校不能重复的方法

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

数组法：

复制代码

zhaogang1960 · 发表于 2012-7-19 17:45

为了避免使用Do语句造成死循环，采用乱序排序模拟随机取值，请参考：

Sub Macro1()
Dim arr(1 To 2), brr(), i&, j&, m&, n&, r&, l&, lr&, ii&, v&, d As Object, ds As Object
Application.ScreenUpdating = False
Set d = CreateObject("scripting.dictionary")
Set ds = CreateObject("scripting.dictionary")
lr = Range("A65536").End(xlUp).Row - 1
ReDim brr(1 To lr, 1 To 1)
For i = 1 To lr
brr(i, 1) = Int((Rnd * lr) + 1)
Next
[e2].Resize(lr) = brr
m = [d:d].Find("女", , , xlWhole).Row
With Range("a2:e" & m - 1)
.Sort Key1:=[e2]
arr(1) = .Value
End With
With Range("a" & m & ":e" & [a65536].End(3).Row)
.Sort Key1:=.Cells(1, 5)
arr(2) = .Value
End With
Columns("e:j").ClearContents
[g1:j1] = Array("宿舍号", "姓名", "学校", "性别")
For l = 1 To 2
For i = 1 To UBound(arr(l))
d(i) = ""
Next
ReDim brr(1 To UBound(arr(l)), 1 To 4)
r = 0
For i = 1 To WorksheetFunction.RoundUp(UBound(arr(l)) / 6, 0) - 1
For v = 1 To 6
For ii = 1 To UBound(arr(l))
If Len(arr(l)(ii, 3)) Then
If Not ds.Exists(arr(l)(ii, 3)) Then
r = r + 1
ds(arr(l)(ii, 3)) = ""
d.Remove ii
brr(r, 1) = i
For j = 2 To 4
brr(r, j) = arr(l)(ii, j)
Next
arr(l)(ii, 3) = ""
Exit For
End If
End If
Next
Next
ds.RemoveAll
Next
k = d.keys
m = i
For i = 0 To d.Count - 1
r = r + 1
brr(r, 1) = m
For j = 2 To 4
brr(r, j) = arr(l)(k(i), j)
Next
Next
[g65536].End(3).Offset(1).Resize(r, 4) = brr
d.RemoveAll
Next
[a1].CurrentRegion.Sort Key1:=[a2], Header:=xlYes
Application.ScreenUpdating = True
End Sub

复制代码

zhaogang1960 · 发表于 2012-7-19 17:46

请看附件

宿舍分配222.rar (19.6 KB, 下载次数: 65)

小花鹿 · 发表于 2012-7-20 11:39

本帖最后由小花鹿于 2012-7-20 11:44 编辑

现把附件改一下：
1、把学校和性别改成了乱序排列
2、增加了一个随机抽取的条件

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

继续征求既高效又易懂的代码。
表2是模拟结果，由于人名是随机抽取的，所以这个模拟结果只是一个样子。
最好是只用数组和字典，不用SORT或工作表函数等。

zhaogang1960 · 发表于 2012-7-20 13:15

小花鹿发表于 2012-7-20 11:39
现把附件改一下：
1、把学校和性别改成了乱序排列
2、增加了一个随机抽取的条件

不应排斥工作表排序方法，好像还没有超过Sort方法的VBA排序法
提供一个思路：
1、求出男女人数后，使用数组生成不重复随机数放到一个一维数组中，按照这个数组的顺序分别存放男女数据，这样就完成了随机数
2、再用12楼方法后半部分思路

小花鹿 · 发表于 2012-7-20 13:34

zhaogang1960 发表于 2012-7-20 13:15
不应排斥工作表排序方法，好像还没有超过Sort方法的VBA排序法
提供一个思路：
1、求出男女人数后，使用 ...

好的，我试试。
一定要好好研究一下这个题目，很有实际意义。

fanchunke1991 · 发表于 2012-7-20 16:13

谢谢各位老师的帮助，也希望这个问题能够得到更多人的关注，得到更加漂亮的程序！

香川群子 · 发表于 2012-7-20 21:24

小花鹿发表于 2012-7-20 11:39
现把附件改一下：
1、把学校和性别改成了乱序排列
2、增加了一个随机抽取的条件

学校乱序有道理，性别就最好分开……反正不同的性别肯定不能同宿舍。

完全可以男生女生分开放置在不同的区域，用同样的代码处理就可以了。

小花鹿 · 发表于 2012-7-20 21:32

香川群子发表于 2012-7-20 21:24
学校乱序有道理，性别就最好分开……反正不同的性别肯定不能同宿舍。

完全可以男生女生分开放置在不同 ...

学校和性别乱序都是有可能的，比如这个表是按学生报名时的顺序填写的，而分宿舍时又不想打乱这个顺序。

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

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