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

fanchunke1991

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

bluexuemei

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

fanchunke1991

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

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

fanchunke1991

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

TOO-布丁

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

fanchunke1991

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

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

zhaogang1960

短信收到，请测试：

1. Sub Macro1()
   
2.     Dim arr(1 To 2), brr(), i&, j&, m&, n&, r&, l&, d As Object, ds As Object
   
3.     Set d = CreateObject("scripting.dictionary")
   
4.     Set ds = CreateObject("scripting.dictionary")
   
5.     m = [d:d].Find("女", , , xlWhole).Row
   
6.     arr(1) = Range("a2:d" & m - 1)
   
7.     arr(2) = Range("a" & m & ":d" & [a65536].End(3).Row)
   
8.     Columns("G:J").ClearContents
   
9.     [g1:j1] = Array("宿舍号", "姓名", "学校", "性别")
   
10.     For l = 1 To 2
    
11.         For i = 1 To UBound(arr(l))
    
12.             ds(i) = ""
    
13.         Next
    
14.         ReDim brr(1 To UBound(arr(l)), 1 To 4)
    
15.         lr = UBound(arr(l))
    
16.         r = 0
    
17.         For i = 1 To WorksheetFunction.RoundUp(lr / 6, 0) - 1
    
18.             Do
    
19.                 n = Int((lr * Rnd) + 1)
    
20.                 If Len(arr(l)(n, 3)) Then
    
21.                     If Not d.Exists(arr(l)(n, 3)) Then
    
22.                         r = r + 1
    
23.                         d(arr(l)(n, 3)) = ""
    
24.                         brr(r, 1) = i
    
25.                         For j = 2 To 4
    
26.                             brr(r, j) = arr(l)(n, j)
    
27.                         Next
    
28.                         arr(l)(n, 3) = ""
    
29.                         ds.Remove (n)
    
30.                     End If
    
31.                 End If
    
32.             Loop Until d.Count = 6
    
33.             d.RemoveAll
    
34.         Next
    
35.         k = ds.keys
    
36.         m = i
    
37.         For i = 0 To ds.Count - 1
    
38.             r = r + 1
    
39.             brr(r, 1) = m
    
40.             For j = 2 To 4
    
41.                 brr(r, j) = arr(l)(k(i), j)
    
42.             Next
    
43.         Next
    
44.         [g65536].End(3).Offset(1).Resize(lr, 4) = brr
    
45.         ds.RemoveAll
    
46.     Next
    
47. End Sub
    
48. 
    

复制代码

zhaogang1960

请看附件
宿舍分配.rar (18.5 KB, 下载次数: 173)

2012-7-19 13:17 上传

点击文件名下载附件

fanchunke1991

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

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

小花鹿

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

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