|
|
楼主 |
发表于 2013-5-20 13:03
|
显示全部楼层
本帖最后由 小花鹿 于 2013-5-23 13:00 编辑
香川群子 发表于 2013-5-18 22:04 
依次从上到下、从左到右的顺序进行随机抽取，
检查比对时，其实只要比对前一行和左一列是否有同校即可。
...
你的代码很复杂，检查校名的二维座位表和FILTER用得都很巧妙，我现在基本懂点了，不知以后能不能灵活运用。
比葫芦画瓢写了一个代码：
小学升学考试座位表.rar
(21.16 KB, 下载次数: 19)
Sub kaochang()
Randomize
Dim ar, drs, dxh, i&, Hs&, Ls&, H&, L&, xmb, zwb, drsi, xh, xm, tm, M, drsk, n, r&, s
Set drs = CreateObject("Scripting.Dictionary") '记录各校人数
Set dxh = CreateObject("Scripting.Dictionary") '记录序号&学校
Sheet3.Columns("h:m").ClearContents
'redo:
ar = Sheet3.[a1].CurrentRegion
For i = 2 To UBound(ar)
drs(ar(i, 1)) = drs(ar(i, 1)) + 1
dxh(CStr(i)) = i & " " & ar(i, 1)
Next i
Hs = 7: Ls = 6 '考场7行6列
For i = 0 To (UBound(ar) - 2) / 40 '减2是因为其中1个是表头，这里是93人，93/40=2.325,0-2.325是3个考场，如果是80个人80/40=2，0-2也是3个考场，就不对了，所以(80-1)/40=1.975,是2个考场
ReDim xmb(Hs, Ls) '初始化记录校名的数组,这个数组的使用很巧妙
ReDim zwb(1 To Hs, 1 To Ls) '初始化记录座位的数组
For H = 1 To Hs '遍历考场的各行
For L = 1 To Ls '遍历考场的各列
If H = Hs And (L = 1 Or L = Ls) Then '考场的下面两个角
'不做任何操作
Else
s = dxh.items '序号&学校 数据更新
tm = "" '学校名清空
drsi = drs.items '学校人数更新
M = Application.Max(drsi) '查找学校人数最多的
n = Application.Match(M, drsi, 0) '最多人数位置
drsk = drs.keys '取得各学校名
tm = drsk(n - 1) '最多人数对应的学校
If tm <> xmb(H - 1, L) And tm <> xmb(H, L - 1) Then '前面、左面没有同校
s = Filter(s, tm, True) '过虑出该校清单
Else
tm = "" '不选择该校
End If
If tm = "" Then
tm = xmb(H - 1, L): If tm <> "" Then s = Filter(s, xmb(H - 1, L), False) '去掉前面的学校的学生
tm = xmb(H, L - 1): If tm <> "" Then s = Filter(s, xmb(H, L - 1), False) '去掉左面的学校的学生
End If
'If UBound(s) = -1 Then GoTo redo
r = Int(Rnd() * (UBound(s) + 1)) '在过虑后得到的清单中随机抽取1个
xh = Split(s(r), " ")(0) '取得序号
dxh.Remove xh '此人已抽出，从字典中去掉
xm = Split(s(r), " ")(1) '得到校名
xmb(H, L) = xm '记到学校检查表（数组）中，便于后面检查是否有同校
zwb(H, L) = xm & ar(xh, 4) '记入输出考场表中（数组),zwb（座位表)
If drs(xm) = 1 Then drs.Remove (xm) Else drs(xm) = drs(xm) - 1 '如果此校只剩1个学生，该生已被抽出，所以去掉该校，否则该校人数减1
If dxh.Count = 0 Then GoTo over '字典空了，说明所有学生已被抽出，所以退出H、L循环
End If
Next L
Next H
over:
Sheet3.[h65536].End(3).Offset(3).Resize(Hs, Ls) = zwb
Next i
End Sub
现在有2个问题请教：
1、我没用你所说的死循环参数，似乎运行起来也没什么问题，不用可以吗？
2、我上面的代码专门注释掉了两句，'redo: 和 'If UBound(s) = -1 Then GoTo redo ，这样会出错，原因是Ubound(s)=-1，我的理解是s中没有学生，那么，为什么有时会出现s中没有学生的情况呢？
定下一个模型，以后就用这个模型了，优点是代码简单点，缺点是人数在各考场中分布不均匀：
小学升学考试座位表1.rar
(26.51 KB, 下载次数: 27)
Sub test2()
Randomize
Dim ar, br(), drs, dxh, i&, Hs&, Ls&, xmb(), zwb(), H&, L&, s, M, tm, drsk, r&, xh, xm
Set drs = CreateObject("scripting.dictionary")
Set dxh = CreateObject("scripting.dictionary")
ar = Sheet3.[a1].CurrentRegion
redo:
ReDim br(2 To UBound(ar), 1 To 2)
Sheet3.Columns("h:m").ClearContents
Sheet3.[e2:f999].ClearContents
For i = 2 To UBound(ar)
drs(ar(i, 1)) = drs(ar(i, 1)) + 1
dxh(CStr(i)) = i & " " & ar(i, 1)
Next i
Hs = 7: Ls = 6
For i = 0 To (UBound(ar) - 2) / 40
ReDim xmb(Hs, Ls)
ReDim zwb(1 To Hs, 1 To Ls)
For H = 1 To Hs
For L = 1 To Ls
If H = Hs And (L = 1 Or L = Ls) Then
Else
s = dxh.items
M = Application.Max(drs.items)
M = Application.Match(M, drs.items, 0)
drsk = drs.keys
tm = drsk(M - 1)
If tm <> xmb(H - 1, L) And tm <> xmb(H, L - 1) Then
s = Filter(s, tm, True)
Else
tm = xmb(H - 1, L): If tm <> "" Then s = Filter(s, tm, False)
tm = xmb(H, L - 1): If tm <> "" Then s = Filter(s, tm, False)
End If
If UBound(s) = -1 Then GoTo redo
r = Int(Rnd() * (UBound(s) + 1))
xh = Split(s(r), " ")(0)
dxh.Remove (xh)
xm = Split(s(r), " ")(1)
xmb(H, L) = xm
zwb(H, L) = xm & ar(xh, 4)
br(xh, 1) = i + 1: br(xh, 2) = H & "行" & L & "列"
If drs(xm) = 1 Then drs.Remove (xm) Else drs(xm) = drs(xm) - 1
If dxh.Count = 0 Then GoTo ext
End If
Next L
Next H
ext:
Sheet3.[h65536].End(3).Offset(3).Resize(Hs, Ls) = zwb
Next i
Sheet3.[e2].Resize(UBound(br) - 1, 2) = br
End Sub
Sub test2() '考虑了某校人数大于总人数一半的情况，肯定出现空位
Randomize
Dim ar, br(), drs, dxh, i&, Hs&, Ls&, xmb(), zwb(), H&, L&, s, s1, s2, M, tm, drsk, r&, xh, xm, Mx, Mz, Mw
Set drs = CreateObject("scripting.dictionary")
Set dxh = CreateObject("scripting.dictionary")
ar = Sheet3.[a1].CurrentRegion
redo:
ReDim br(2 To UBound(ar), 1 To 2)
Sheet3.Columns("h:m").ClearContents
Sheet3.[e2:f999].ClearContents
For i = 2 To UBound(ar)
drs(ar(i, 1)) = drs(ar(i, 1)) + 1
dxh(CStr(i)) = i & "," & ar(i, 1)
Next i
Hs = 7: Ls = 6
Mx = Application.Max(drs.items)
Mw = Application.Match(Mx, drs.items, 0)
drsk = drs.keys
tm = drsk(Mw - 1)
Mz = dxh.Count
If Mx <= Mz / 2 Then
For i = 0 To (UBound(ar) - 2) / 40
ReDim xmb(Hs, Ls)
ReDim zwb(1 To Hs, 1 To Ls)
For H = 1 To Hs
For L = 1 To Ls
If H = Hs And (L = 1 Or L = Ls) Then
Else
s = dxh.items
M = Application.Max(drs.items)
M = Application.Match(M, drs.items, 0)
drsk = drs.keys
tm = drsk(M - 1)
If tm <> xmb(H - 1, L) And tm <> xmb(H, L - 1) Then
s = Filter(s, tm, True)
Else
tm = xmb(H - 1, L): If tm <> "" Then s = Filter(s, tm, False)
tm = xmb(H, L - 1): If tm <> "" Then s = Filter(s, tm, False)
End If
If UBound(s) = -1 Then GoTo redo
r = Int(Rnd() * (UBound(s) + 1))
xh = Split(s(r), ",")(0)
dxh.Remove (xh)
xm = Split(s(r), ",")(1)
xmb(H, L) = xm
zwb(H, L) = xm & ar(xh, 4)
br(xh, 1) = i + 1: br(xh, 2) = H & "行" & L & "列"
If drs(xm) = 1 Then drs.Remove (xm) Else drs(xm) = drs(xm) - 1
If dxh.Count = 0 Then GoTo ext
End If
Next L
Next H
ext:
Sheet3.[h65536].End(3).Offset(3).Resize(Hs, Ls) = zwb
Next i
Sheet3.[e2].Resize(UBound(br) - 1, 2) = br
Else
For i = 0 To (Mx - 1) / 20
ReDim zwb(1 To Hs, 1 To Ls)
For H = 1 To Hs
For L = 1 To Ls Step 2
If H = Hs And (L = 1 Or L = Ls) Then
Else
s = dxh.items: s1 = Filter(s, tm, True): s2 = Filter(s, tm, False)
If UBound(s1) <> -1 Then
r = Int(Rnd() * (UBound(s1) + 1))
xh = Split(s1(r), ",")(0)
dxh.Remove (xh)
zwb(H, L + ((H - 1) Mod 2)) = ar(xh, 1) & ar(xh, 4)
End If
If UBound(s2) <> -1 Then
r = Int(Rnd() * (UBound(s2) + 1))
xh = Split(s2(r), ",")(0)
dxh.Remove (xh)
zwb(H, L + (H Mod 2)) = ar(xh, 1) & ar(xh, 4)
End If
End If
Next L
Next H
zwb(7, 2) = zwb(7, 6): zwb(7, 6) = ""
Sheet3.[h4].Offset(i * 9).Resize(Hs, Ls) = zwb
Next i
End If
End Sub
|
|
楼主: 小花鹿
[复制链接]
沪公网安备 31011702000001号 沪ICP备11019229号-2
发表于 2013-5-17 16:53
