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

小花鹿

zhaogang1960 发表于 2012-7-22 11:16
确有Bug，某些排序会出现找不出6个不同的学校，看来此法不通，加一个判断，如果出现这种情况，一切推倒 ...

多次运行还是会有重复：

小花鹿

zhaogang1960 发表于 2012-7-22 12:48
幸亏楼主给出的数据比较合理，如果数据大多数来自一个学校，该程序根本就无法运行，能把重复数据放到最后 ...

是啊，如果一个学校的人数很多会很麻烦的。

zhaogang1960

小花鹿 发表于 2012-7-22 12:52
多次运行还是会有重复：

测试的很仔细，再加一个判断，最后一组如果有重复则再推倒重来：
            s = ""
            For i = 0 To d.Count - 1
                r = r + 1
                u = u + 1
                brr(r, 1) = m
                If InStr(s & ",", "," & arr(l)(k(i), 3) & ",") = 0 Then
                    s = s & "," & arr(l)(k(i), 3)
                    For j = 2 To 4
                        brr(r, j) = arr(l)(k(i), j)
                    Next
                Else
                    f = True
                    Exit For
                End If
            Next
宿舍分配222rr.rar (19.66 KB, 下载次数: 31)

2012-7-22 13:07 上传

点击文件名下载附件

香川群子

小花鹿 发表于 2012-7-22 12:57
是啊，如果一个学校的人数很多会很麻烦的。

有趣的是，我发现，结果也许和你的常识相反：

学生人数如果比较集中于几个学校，只要每一个学校的初始人数没有大于总人数的1/6，就绝对没有问题，
反而容易处理。


反而是，楼主例子中，人数大于6个的学校数量较多时，随机抽到最后，容易有剩余造成死循环。

小花鹿

香川群子 发表于 2012-7-22 16:47
有趣的是，我研究发现，结果正好和你的常识相反：

学生人数如果比较集中于几个学校，只要每一个学校的 ...

实在看不懂，不玩了，先放下。
有问题实在解决不了，暂时放下，也是一种选择，终有解决的时候。

香川群子

小花鹿 发表于 2012-7-22 17:09
实在看不懂，不玩了，先放下。
有问题实在解决不了，暂时放下，也是一种选择，终有解决的时候。

我的代码中已经有详细注释了，你还是看不懂么？


基本原理其实也很简单。


1. 6人一个房间，因此每抽6个人为一次循环。
2. 每个房间的抽取过程中，首先随机抽1人，然后剩余人数要排除和这个人相同学校的同学。→用filter方法。
3. 接下来的5个人，每次都要把剩余人数中，排除前面已经抽取过的学校的同学。

以上是基本思路，可以保证一次性抽取完成。

接下来，出现的问题是，如何防止死循环。
研究可知，死循环的实际条件是：【某个学校的剩余人数，已经大于剩余房间数】

那么，解决问题的方法也很简单。
【每个房间开始抽取时，优先判断那个学校的剩余人数已经相当，或接近剩余房间数。】

如果符合条件，那么就【强制性、优先抽取】这个学校的人。


呵呵。如果理解了这个做法，那么具体实现的代码算法，你应该就能理解了。

1. 用字典1统计并更新每次抽取后剩余人数
2. 用字典2汇总剩余人的学校信息。并用数组提取结果，以便用fileter方法过滤。

小花鹿

香川群子 发表于 2012-7-22 17:24
我的代码中已经有详细注释了，你还是看不懂么？

确实看不懂，太复杂了，注释没用处，我能看懂的，没有注释也能看懂。

小花鹿

香川群子 发表于 2012-7-22 16:47
有趣的是，我发现，结果也许和你的常识相反：

学生人数如果比较集中于几个学校，只要每一个学校的初始 ...

虽然我还没有弄懂你的代码，但是测试了一下，如果某个学校的女生很多，比如P校有30个女生，就会错误。
这种情况极端情况下还是有可能发生的。
另外，能不能不用GOTO？
为了简化，可以只排女生或者只排男生，反正道理是一样的，

小花鹿

重新写了一下代码，附件中的源数据是经过修改了的，为了便于测试。
优点：
1、确保不重复。
2、确保占用最少的宿舍，占用宿舍的多少不仅与总人数有关，也与每校的人数有关，比如附件中男生是86人，按6人算的话应该是15个宿舍，但情况并非如此，因为K学校有34个人，所以必须占用34个宿舍。
3、代码从上到下顺序运行，没有交叉，各单元有自己的功能，易于理解。
4、单元格操作少，因此速度较快，但有较多的无用循环，因为图写代码简单，也就没有管它。
缺点：
1、没有做到只有一个宿舍不满6人，这种要求有时候可以实现，有时候根本无法实现，如果人数都集中在一两个学校不足6人的宿舍会很多，如果保证占用最少的宿舍，不满6人何妨？也许会说，虽然不能做到只有一个宿舍不满6人，但可做到最大限度的满6人，这应该可以做到，但我不会，等高手。
2、同校学生排在了相邻的的宿舍，这也没什么，比如K校有34人，必定都排在相邻的宿舍，如果需要，可以用随机函数把它打乱。
一定会有漏洞存在，请测试的朋友指出来。
Sub test()
Dim ar1, ar2, cr(), br(), xb, r&, n&, s, i&, j&, k&, x&, d, rs&, rm&, t
t = Timer
Set d = CreateObject("scripting.dictionary")
Sheet2.Cells.Clear
ar1 = Sheet1.[a1].CurrentRegion
ar2 = ar1
r = UBound(ar1)
ReDim cr(2 To r)
For i = 2 To r
    cr(i) = i
Next i
For i = 2 To r
    n = Int(Rnd() * (r - i + 1)) + i
    s = cr(i)
    cr(i) = cr(n)
    cr(n) = s
Next i
For i = 2 To r
    For j = 1 To 4
        ar2(i, j) = ar1(cr(i), j)
    Next j
Next i
xb = Array("男", "女")
For x = 0 To 1
    n = 0: rs = 0: rm = 0
    ReDim ar1(1 To r, 1 To r)
    For i = 2 To r
        If ar2(i, 4) = xb(x) Then
            rs = rs + 1
            If d.exists(ar2(i, 3)) = 0 Then
                n = n + 1
                d(ar2(i, 3)) = n
                ar1(n, i) = ar2(i, 3) & ar2(i, 2)
            Else
                ar1(d(ar2(i, 3)), i) = ar2(i, 3) & ar2(i, 2)
            End If
        End If
    Next i
    d.RemoveAll
    ReDim cr(1 To r * 6)
    k = 0
    For i = 1 To n
        s = 0
        For j = 1 To r
            If ar1(i, j) <> "" Then
                k = k + 1
                cr(k) = ar1(i, j)
                s = s + 1
            End If
        Next j
        If rm < s Then rm = s
    Next i
    If Int((rs - 1) / 6) + 1 > rm Then rm = Int((rs - 1) / 6) + 1
    ReDim br(1 To rm, 1 To 7)
    For i = 1 To rm
        br(i, 1) = xb(x) & "舍_" & i
        For j = 2 To 7
            br(i, j) = cr((j - 2) * rm + i)
        Next j
    Next i
    Sheet2.[a65536].End(3).Offset(1).Resize(rm, 7) = br
Next x
MsgBox Format(Timer - t, "0.000")
End Sub

香川群子

小花鹿 发表于 2012-7-22 21:19
虽然我还没有弄懂你的代码，但是测试了一下，如果某个学校的女生很多，比如P校有30个女生，就会错误。
这 ...

P校30个女生，远远超过6人一个宿舍时宿舍总数。

这个改变太大，和楼主的题目比就完全没有边了。

……
如果客观上有这样的情况存在，那么要求每个宿舍都没有同一学校的学生，这条规则就必须改了。


因为，存在很多不满员的空宿舍，占用更多宿舍几乎是无法想象的 愚蠢行为。