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

fanchunke1991 · 发表于 2012-7-19 09:27

本帖最后由 fanchunke1991 于 2012-7-19 11:28 编辑

想利用VBA进行排列组合，解决一个实际的问题。
说明：要对学生进行宿舍的分配，学生来源于20个不同的学校，要求每个宿舍6人，他们要来源于不同的学校，也就是同一个学校的学生不能住在同一个宿舍。具体的要求在附件里面。
本人初学VBA，所以有些复杂的问题自己还是不能解决，还希望各位VBA高手能帮忙解决，不胜感激！
宿舍分配.rar

bluexuemei · 发表于 2012-7-19 09:54

这个题目很实用,不过有点棘手.

fanchunke1991 · 发表于 2012-7-19 09:58

bluexuemei 发表于 2012-7-19 09:54
这个题目很实用,不过有点棘手.

还请这位老师帮帮忙，看能不能解决。谢谢！

fanchunke1991 · 发表于 2012-7-19 10:32

本帖最后由 fanchunke1991 于 2012-7-19 11:12 编辑

有高手吗？求求帮帮忙！{:soso_e154:}

TOO-布丁 · 发表于 2012-7-19 12:14

用笨笨的方法写下:没有填充颜色的为还没有分配宿舍:

fanchunke1991 · 发表于 2012-7-19 13:15

TOO-布丁发表于 2012-7-19 12:14
用笨笨的方法写下:没有填充颜色的为还没有分配宿舍:

非常感谢。不过每一个分组中学校的排列组合能不能更分散一些，更随机一些？

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

短信收到，请测试：

Sub Macro1()
Dim arr(1 To 2), brr(), i&, j&, m&, n&, r&, l&, d As Object, ds As Object
Set d = CreateObject("scripting.dictionary")
Set ds = CreateObject("scripting.dictionary")
m = [d:d].Find("女", , , xlWhole).Row
arr(1) = Range("a2:d" & m - 1)
arr(2) = Range("a" & m & ":d" & [a65536].End(3).Row)
Columns("G:J").ClearContents
[g1:j1] = Array("宿舍号", "姓名", "学校", "性别")
For l = 1 To 2
For i = 1 To UBound(arr(l))
ds(i) = ""
Next
ReDim brr(1 To UBound(arr(l)), 1 To 4)
lr = UBound(arr(l))
r = 0
For i = 1 To WorksheetFunction.RoundUp(lr / 6, 0) - 1
Do
n = Int((lr * Rnd) + 1)
If Len(arr(l)(n, 3)) Then
If Not d.Exists(arr(l)(n, 3)) Then
r = r + 1
d(arr(l)(n, 3)) = ""
brr(r, 1) = i
For j = 2 To 4
brr(r, j) = arr(l)(n, j)
Next
arr(l)(n, 3) = ""
ds.Remove (n)
End If
End If
Loop Until d.Count = 6
d.RemoveAll
Next
k = ds.keys
m = i
For i = 0 To ds.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(lr, 4) = brr
ds.RemoveAll
Next
End Sub

复制代码

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

请看附件

宿舍分配.rar (18.5 KB, 下载次数: 177)

fanchunke1991 · 发表于 2012-7-19 13:24

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

非常感谢版主的帮助，真的很有用，谢谢！

小花鹿 · 发表于 2012-7-19 14:38

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

不断重复运行程序，有时候会处于没有响应状态，不知什么原因？

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

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

评分

评分