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

Moneky · 发表于 2012-7-23 15:42

学习一下，顺便凑个数。我的做法是根据情况计算出所需要的宿舍数，然后把学生依次放进去。不存在死循环的问题，各个宿舍的人数尽量平均，不会出现人数显著少的宿舍（宿舍人数最多差1）。对于某个学校人数过多的情况（大于宿舍数量），直接改写宿舍数量，这在现实生活中应该不现实，在实际操作中应该会允许出现一个宿舍有两个同校生的情况的，不然宿舍需求量就太大了。

Option Explicit
Sub DoMyWork()
'1=man 2=women
Dim bdrr
Dim rr1() As String
Dim rr2() As String
Dim dic1 As New Dictionary
Dim dic2 As New Dictionary
Dim sht1 As Worksheet
Dim max1 As Long '男女最大人数
Dim max2 As Long
Dim count1 As Long '男女生总数
Dim count2 As Long
Dim house1 As Long '男女生所需宿舍数
Dim house2 As Long
Dim i As Long
Dim j As Long
Dim n1 As Long
Dim n2 As Long
Set sht1 = ThisWorkbook.Worksheets(1)
With sht1
bdrr = .Range(.Cells(2, 2), .Cells(.Cells(1, 4).End(xlDown).Row, 4)) '源表数据区域
End With
For i = 1 To UBound(bdrr)
If bdrr(i, 3) = "男" Then '按男女分拣
If Not dic1.Exists(bdrr(i, 2)) Then Set dic1(bdrr(i, 2)) = New Dictionary
dic1(bdrr(i, 2)).Add bdrr(i, 1), 1
If dic1(bdrr(i, 2)).Count > max1 Then max1 = dic1(bdrr(i, 2)).Count '记录最大数
count1 = count1 + 1 '统计总数
Else
If Not dic2.Exists(bdrr(i, 2)) Then Set dic2(bdrr(i, 2)) = New Dictionary
dic2(bdrr(i, 2)).Add bdrr(i, 1), 1
If dic2(bdrr(i, 2)).Count > max2 Then max2 = dic2(bdrr(i, 2)).Count
count2 = count2 + 1
End If
Next
house1 = count1 \ 6 '计算所需宿舍数
house1 = IIf(house1 * 6 = count1, house1, house1 + 1)
house2 = count2 \ 6
house2 = IIf(house2 * 6 = count2, house2, house2 + 1)
If max1 > house1 Then house1 = max1
If max2 > house2 Then house2 = max2
ReDim rr1(1 To house1, 0 To 6) As String '定义宿舍
ReDim rr2(1 To house2, 0 To 6) As String
Dim drr1, drr2
drr1 = dic1.Keys
n1 = 1
n2 = 1
For i = 1 To house1 '初始化宿舍标志
rr1(i, 0) = "男宿舍" & CStr(i)
Next
For i = 1 To house2
rr2(i, 0) = "女宿舍" & CStr(i)
Next
For i = LBound(drr1) To UBound(drr1) '排男生
drr2 = dic1(drr1(i)).Keys
For j = LBound(drr2) To UBound(drr2)
Debug.Print drr2(j) & "-" & drr1(i)
rr1(n1, n2) = drr1(i) & "-" & drr2(j)
n1 = n1 + 1
If n1 > house1 Then n1 = 1: n2 = n2 + 1
Next
Next
drr1 = dic2.Keys
n1 = 1
n2 = 1
For i = LBound(drr1) To UBound(drr1) '排女生
drr2 = dic2(drr1(i)).Keys
For j = LBound(drr2) To UBound(drr2)
Debug.Print drr2(j) & "-" & drr1(i)
rr2(n1, n2) = drr1(i) & "-" & drr2(j)
n1 = n1 + 1
If n1 > house2 Then n1 = 1: n2 = n2 + 1
Next
Next
With sht1 '输出结果
.Range("F:L").ClearContents
.Range(.Cells(1, 6), .Cells(house1, 12)) = rr1
.Range(.Cells(house1 + 2, 6), .Cells(house1 + house2 + 1, 12)) = rr2
End With
MsgBox "宿舍学生清单输出完成,请查看!", vbInformation + vbOKOnly, "Eersoft-提示"
End Sub

复制代码

zhangzhang · 发表于 2012-7-23 16:03

个人认为此题比较简单的方法是：
1，按学校(同校学生序号在一起)、性别顺序大排行：序号为 1、2、3......N(N〉=6），假设 N=315
2，求出宿舍总数 S=roundup(N/6)； S=roundup(315/6)=53
3, 学生序号/53 余数相同的住一个宿舍。（注：一个学校的人数不得超过宿舍总数。）

小花鹿 · 发表于 2012-7-23 19:53

算了，没有讨论问题的氛围，闪了。

小花鹿 · 发表于 2012-7-26 12:48

香川群子发表于 2012-7-21 00:01
刚刚做了测试，发现确实还有bug……到倒数第2宿舍分配时，有时会产生重复错误。

解决方法，是强制抽取的 ...

看看我学习你的代码成果：
Sub test()
Dim ar, br(), xb, r&, i&, j&, k&, x&, xx, dxrs, dhxm, sn&, s, s1, n&, dxk, dxi, t
t = Timer
Randomize
Set dxrs = CreateObject("scripting.dictionary")
Set dhxm = CreateObject("scripting.dictionary")
ar = Sheet1.[a1].CurrentRegion
r = UBound(ar)
xb = Array("男", "女")
Sheet2.Cells.Clear
For x = 0 To 1
For i = 2 To r
      If ar(i, 4) = xb(x) Then
         dxrs(ar(i, 3)) = dxrs(ar(i, 3)) + 1
         dhxm(CStr(i)) = i & "," & ar(i, 3) & "," & ar(i, 2)
      End If
Next i
sn = (dhxm.Count - 1) \ 6 + 1
ReDim xx(5)
ReDim br(1 To sn, 1 To 7)
For i = 1 To sn - 1
      br(i, 1) = xb(x) & "舍_" & i
      For j = 0 To 5
         dxk = dxrs.keys
         dxi = dxrs.items
         For k = 0 To UBound(dxk)
            If dxi(k) = sn - i + 1 Or dxi(k) = sn - i Then
                  s = Filter(dhxm.items, dxk(k), True)
                  GoTo row
            End If
         Next k
         s = dhxm.items
         For k = 0 To j - 1
            s = Filter(s, xx(k), False)
         Next k
row:
         n = Int(Rnd() * (UBound(s) + 1))
         s = Split(s(n), ",")
         br(i, j + 2) = s(1) & s(2)
         xx(j) = s(1)
         If dxrs(s(1)) = 1 Then
            dxrs.Remove s(1)
         Else
            dxrs(s(1)) = dxrs(s(1)) - 1
         End If
         dhxm.Remove (s(0))
      Next j
Next i
s = dhxm.items
br(sn, 1) = xb(x) & "舍_" & sn
For i = 0 To UBound(s)
      s1 = Split(s(i), ",")
      br(sn, i + 2) = s1(1) & s1(2)
Next i
Sheet2.[a65536].End(3).Offset(1).Resize(sn, 7) = br
dxrs.RemoveAll
dhxm.RemoveAll
Next x
MsgBox Format(Timer - t, "0.000s")
End Sub

宿舍分配2.rar (24.61 KB, 下载次数: 28)

三坛老窖 · 发表于 2012-7-26 13:04

小花鹿发表于 2012-7-23 19:53
算了，没有讨论问题的氛围，闪了。

小花鹿你真可爱！老窖还真以为你闪了。
你的级别和你VBA的水平看起来不这么相称，可你的专研精神，还是让老窖心生敬意。

小花鹿 · 发表于 2012-7-26 13:14

三坛老窖发表于 2012-7-26 13:04
小花鹿你真可爱！老窖还真以为你闪了。
你的级别和你VBA的水平看起来不这么相称，可你的专研精神，还是让 ...

级别和VBA水平没有任何关系，级别很高的VBA可能一点不懂，级别很低的可能是顶尖高手。

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

小花鹿发表于 2012-7-26 13:14
级别和VBA水平没有任何关系，级别很高的VBA可能一点不懂，级别很低的可能是顶尖高手。

小花鹿，我在另一个帖子里给你的回复，你咋没有回应呢？

http://club.excelhome.net/thread-896651-3-1.html

【中间列号判断有点复杂了，直接这样不就行了吗？】

从代码结果来看，你这样改当然可以。

问题是，算法就不同了。这个你能自己想明白么？

…………
而我的算法，代码看上去虽然似乎比你改写的要繁琐一点，
但是，如果数据量很大、比如2万行，几千个不同姓名（字典对象）的话，

显然我的算法在速度和内存上都有很大优势。

…………
因此，我的代码的优点，你还要好好研究。

（好的算法，不是为了让别人看得舒服，而是要让机器/电脑高效地运作。）

当然，一般情况下，好的代码算法，往往从结构上看也应该是最简单的……
但是，不能说代码结构越简单，则效率越高 → 这个是不同的含义。

小花鹿 · 发表于 2012-7-27 22:24

香川群子发表于 2012-7-26 14:05
小花鹿，我在另一个帖子里给你的回复，你咋没有回应呢？

http://club.excelhome.net/thread-896651-3- ...

主要是我对这个问题还没有认识清楚，所以不知道怎样回答。

香川群子 · 发表于 2012-7-28 07:25

小花鹿发表于 2012-7-27 22:24
主要是我对这个问题还没有认识清楚，所以不知道怎样回答。

提醒你一下：

算法效率关键：
1. 减少循环次数
尽量在一次循环中把该做的、能做的都做了。

这个你大概能理解，也会去做。

2. 活用中间变量
减少相同内容的反复计算、查询的次数。

显然你还没有这个习惯。
你似乎认为，代码看上去越简单越好，很不愿意增加和使用中间变量。

3. 尽量用数组

这个你懂的

4. 根据需要使用字典

但这个方面规则不是很清晰。

但是需要告诉你，差异主要在于：
字典检索功能的速度效率，和遍历数组循环比对的检索方法之间的速度效率差异。

字典在大量数据的检索中，是高效的，但毕竟也还是要花时间，不是“免费”的。
（这里免费不是指金钱，是指时间、速度效率方面的付出）

因此，结论是：
尽量减少字典的使用（不是指建立字典越少越好的意思，而是指用字典方法检索返回结果的操作）

具体减少字典操作的做法，显然就是使用中间变量。
即，检索一次后得到的结果，存入中间变量，然后就能反复使用了……

这里，就是我的代码，和你的代码的算法上的本质性差异所在了。

5. 字符串操作注意事项

这个暂时不谈了。

比如，用right("000" & t, 3) 要比 format(t,"000") 高效率……

还有mid函数、instr函数、like方法等……

小花鹿 · 发表于 2012-7-28 17:25

香川群子发表于 2012-7-28 07:25
提醒你一下：

算法效率关键：

很有道理，不过我还得在实践中慢慢感知。

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

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

点评

点评

评分