小花鹿学习VBA记录

香川群子 · 发表于 2013-5-20 14:30

相反，如果设定【死循环参数】=1 ，即完全不使用优先抽取剩余人数最多学校的做法时，
那么死循环的出现概率将达到50%以上，即每运行2次就会有一次死循环出现。

这个还是楼主的例子各个学校分布不太集中的情形。

如果某几个学校人数较为集中时，不使用死循环调整代码时将大量出现死循环。

香川群子 · 发表于 2013-5-20 14:36

本帖最后由香川群子于 2013-5-20 14:44 编辑

刚才试了一下，如果黄村校人数比例调整至40%以上时，
如果有优先抽取剩余人数最多学校的处理代码，则运行正常。

但如果设定【死循环参数】=1 ，即不采用我这个算法时，几乎100%出现死循环。
运行很长、很长时间都没有结果了。

又试了一下，黄村校人数比例调整至35%时，
运行57次死循环以后，才有一次碰巧得到正确结果。

如果代码按这个比例，是很失败的。

因此，如果完全随机算法，必须使用我的剩余人数优先规则算法。
这个剩余人数的优先度，就是所谓的【死循环参数p】

理论上p取值范围可以在[0-1]之间。

p=0时，绝对优先提取，估计可以基本上保证99.99%的概率不出现死循环。
p=1时，不进行优先提取，那么非常容易出现死循环。（具体死循环出现概率还要看原始数据的分布)

呵呵。我的算法思路，确实与众不同的。

香川群子 · 发表于 2013-5-20 14:53

2、我上面的代码专门注释掉了两句，'redo: 和 'If UBound(s) = -1 Then GoTo redo ，
这样会出错，原因是Ubound(s)=-1，
我的理解是s中没有学生，那么，为什么有时会出现s中没有学生的情况呢？

…………
答：
1. redo: 被注释掉以后，那么万一出现了死循环就不能重来了。

2. Ubound(s)=-1 意思是：
根据检查校名重复座位表的检查结果筛选以后，没有满足条件的学生存在
（对于下标从0开始的一维数组来说，元素数量=-1 就是没有元素0，即一个元素也没有）

这种情况，往往出现在最后一个学生要放进去时，前面一个位置已经是同校了，
而由于剩余学生只有一个了，排除前后不同校的学生以后Filter得到的一维数组下标=-1，即为空集。

小花鹿 · 发表于 2013-5-21 10:34

本帖最后由小花鹿于 2013-6-4 01:25 编辑

香川群子发表于 2013-5-20 14:21
你的代码看上去是没有用到【死循环参数】，但实际上还是用了，你的【死循环参数】是=0

解释：

也就是说p这个参数决定了能否比较均匀的把某一学校的学生分布在各个考场中，p越小分布的越不均匀，但死循环次数越少，相反，p越大分布的越均匀，但同时死循环次数越多。是这个意思吗？

在这里补充不随机的解法：
1、当某校人数大于总人数的一半时：
Sub test()
Dim ar, drs, dxh, M, i&, drsk, s1, s2, n1&, n2&, zwb, Hs&, Ls&, H&, L&, n&
Set drs = CreateObject("scripting.dictionary")
Set dxh = CreateObject("scripting.dictionary")
ar = Sheet3.[a1].CurrentRegion
For i = 2 To UBound(ar)
drs(ar(i, 1)) = drs(ar(i, 1)) + 1
dxh(ar(i, 1) & ar(i, 4)) = ""
Next i
M = Application.Max(drs.items)
M = Application.Match(M, drs.items, 0)
drsk = drs.keys
M = drsk(M - 1)
s1 = Filter(dxh.keys, M, True)
s2 = Filter(dxh.keys, M, False)
Hs = 7: Ls = 6
For i = 0 To Int((UBound(s1) - 1) / 20)
ReDim zwb(1 To Hs, 1 To Ls)
For H = 1 To Hs
      For L = ((H - 1) Mod 2) + 1 To Ls Step 2
         If H = Hs And L = 1 Then
         Else
            If n1 <= UBound(s1) Then zwb(H, L) = s1(n1): n1 = n1 + 1
         End If
      Next L
Next H
For H = 1 To Hs
      For L = (H Mod 2) + 1 To Ls Step 2
         If H = Hs And L = Ls Then
         Else
            If n2 <= UBound(s2) Then zwb(H, L) = s2(n2): n2 = n2 + 1
         End If
      Next L
Next H
Sheet3.[h2].Offset(i * 8).Resize(Hs, Ls) = zwb
Next i
End Sub

2、当某校人数小于等于总人数的一半时：
Sub test()
Dim ar, i&, j&, r&, zwb(), Hs&, Ls&, H&, L&, n1&, n2&, t&
ar = Sheet3.[a1].CurrentRegion
r = UBound(ar)
Hs = 7: Ls = 6: n1 = 1: n2 = 1: t = Int((r / 2))
For i = 0 To Int((r - 2) / 40)
ReDim zwb(1 To Hs, 1 To Ls)
For H = 1 To Hs
      For L = ((H - 1) Mod 2) + 1 To Ls Step 2
         If H = Hs And L = 1 Then
         Else
            n1 = n1 + 1
            If n1 - 1 <= t Then zwb(H, L) = ar(n1, 1) & ar(n1, 4)
         End If
      Next L
Next H
For H = 1 To Hs
      For L = (H Mod 2) + 1 To Ls Step 2
         If H = Hs And L = Ls Then
         Else
            n2 = n2 + 1
            If n2 + t <= r Then zwb(H, L) = ar(n2 + t, 1) & ar(n2 + t, 4)
         End If
      Next L
Next H
Sheet3.[h2].Offset(i * 8).Resize(Hs, Ls) = zwb
Next i
End Sub

如果要适合两者，可以把上面两段代码合起来。

考场安排代码改进：
优点：
1、尽量做到随机抽取
2、不用以学校进行排序
3、考虑到了某校人数小于等于总人数的一半（这时没有空位）和某校人数大于总人数的一半（这时有空位）两种情况

小学升学考试座位表.rar (33.23 KB, 下载次数: 39)
Sub testx()
Randomize
Dim ar, drs, dxh, i&, Hs&, Ls&, H&, L&, M&, kc&, drsi, drsk, xmb, zwb, s, tm, r, xh, xm, Mxm
Set drs = CreateObject("scripting.dictionary")
Set dxh = CreateObject("scripting.dictionary")
ar = Sheet3.[a1].CurrentRegion
redo:
For i = 2 To UBound(ar)
drs(ar(i, 1)) = drs(ar(i, 1)) + 1
dxh(CStr(i)) = i & "," & ar(i, 1)
Next i
i = Application.Max(drs.items)
M = Int((i - 1) / 20)
kc = Int((UBound(ar) - 2) / 40)
If M > kc Then kc = M
i = Application.Match(i, drs.items, 0)
drsk = drs.keys
Mxm = drsk(i - 1)
Hs = 7: Ls = 6
For i = 0 To kc
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
            If drs.Count = 1 And (xmb(H - 1, L) = Mxm Or xmb(H, L - 1) = Mxm) Then L = L + 1
            If L > Ls Then Exit For
            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 drs.RemoveAll: dxh.RemoveAll: GoTo redo
            r = Int(Rnd() * (UBound(s) + 1))
            xh = Split(s(r), ",")(0)
            dxh.Remove (xh)
            zwb(H, L) = ar(xh, 1) & ar(xh, 4)
            xm = Split(s(r), ",")(1)
            xmb(H, L) = xm
            If drs(xm) = 1 Then drs.Remove (xm) Else drs(xm) = drs(xm) - 1
         End If
         If dxh.Count = 0 Then GoTo ext
      Next L
Next H
ext:
Sheet3.[h4].Offset(i * 8).Resize(Hs, Ls) = zwb
Next i
End Sub

Sub testx()
Randomize
Dim ar, drs, dxh, i&, Hs&, Ls&, H&, L&, M&, kc&, drsi, drsk, xmb, zwb, s, tm, r, xh, xm, Mxm
Set drs = CreateObject("scripting.dictionary")
Set dxh = CreateObject("scripting.dictionary")
ar = Sheet3.[a1].CurrentRegion
redo:
For i = 2 To UBound(ar)
drs(ar(i, 1)) = drs(ar(i, 1)) + 1
dxh(CStr(i)) = i & "," & ar(i, 1)
Next i
i = Application.Max(drs.items)
M = Int((i - 1) / 20)
kc = Int((UBound(ar) - 2) / 40)
If M > kc Then kc = M
i = Application.Match(i, drs.items, 0)
drsk = drs.keys
Mxm = drsk(i - 1)
Hs = 7: Ls = 6
For i = 0 To kc
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
If drs.Count = 1 And (xmb(H - 1, L) = Mxm Or xmb(H, L - 1) = Mxm) Then L = L + 1
If L > Ls Then Exit For
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 drs.RemoveAll: dxh.RemoveAll: GoTo redo
r = Int(Rnd() * (UBound(s) + 1))
xh = Split(s(r), ",")(0)
dxh.Remove (xh)
zwb(H, L) = ar(xh, 1) & ar(xh, 4)
xm = Split(s(r), ",")(1)
xmb(H, L) = xm
If drs(xm) = 1 Then drs.Remove (xm) Else drs(xm) = drs(xm) - 1
End If
If dxh.Count = 0 Then GoTo ext
Next L
Next H
ext:
Sheet3.[h4].Offset(i * 8).Resize(Hs, Ls) = zwb
Next i
End Sub

复制代码

香川群子 · 发表于 2013-5-21 11:55

小花鹿发表于 2013-5-21 10:34
也就是说p这个参数决定了能否比较均匀的把某一学校的学生分布在各个考场中，p越小分布的越不均匀，但死循 ...

没错。所以我觉得还是加上这个参数比较好。

具体应用时，可以测试几次、几十次，然后确定一个p参数值，比如本例我认为=30%比较好。

然后就可以把这参数作为代码的一部分写进去，后台运行了。

呵呵。我是不是考虑问题过于复杂了？！呵呵。

小花鹿 · 发表于 2013-5-22 17:09

香川群子发表于 2013-5-21 11:55
没错。所以我觉得还是加上这个参数比较好。

具体应用时，可以测试几次、几十次，然后确定一个p参数值， ...

还记得宿舍分配的那个帖子吧，我用现在的方法又写了一次代码，虽然没有你考虑的全面，但我能基本掌握此类题目的解法就已经很高兴了。

宿舍分配.rar (30.39 KB, 下载次数: 35)

Sub test1()
Randomize
Dim ar, xmb(), ssb(), cr, drs, dxh, i&, j&, k&, x&, s, r&, M, drsi, drsk, xh, xm, n
Set drs = CreateObject("scripting.dictionary")
Set dxh = CreateObject("scripting.dictionary")
ar = Sheet1.[a1].CurrentRegion
cr = Array("男", "女")
Sheet3.Columns("a:g").ClearContents
For i = 0 To UBound(cr)
For j = 2 To UBound(ar)
      If ar(j, 4) = cr(i) Then
         drs(ar(j, 3)) = drs(ar(j, 3)) + 1
         dxh(CStr(j)) = j & "," & ar(j, 3)
      End If
Next j
n = dxh.Count
For j = 0 To Int((n - 1) / 6)
      ReDim xmb(1 To 6)
      ReDim ssb(6)
      drsi = drs.items
      drsk = drs.keys
      For k = 1 To 6
         s = dxh.items
         For x = 1 To 6
            If xmb(x) <> "" Then s = Filter(s, xmb(x), False)
         Next x
         M = Application.Max(drsi)
         M = Application.Match(M, drsi, 0)
         drsi(M - 1) = 0
         M = drsk(M - 1)
         s = Filter(s, M, True)
         r = Int(Rnd() * (UBound(s) + 1))
         xh = Split(s(r), ",")(0)
         dxh.Remove (xh)
         xm = Split(s(r), ",")(1)
         ssb(k) = xm & ar(xh, 2)
         xmb(k) = xm
         If drs(xm) = 1 Then drs.Remove (xm) Else drs(xm) = drs(xm) - 1
         If dxh.Count = 0 Then Exit For
      Next k
      ssb(0) = cr(i) & "舍" & (j + 1)
      Sheet3.[a65536].End(3).Offset(1).Resize(1, 7) = ssb
Next j
drs.RemoveAll: dxh.RemoveAll
Next i
End Sub
Sub test2()
Dim i&
For i = 1 To 1000
Call test1
Next i
End Sub

香川群子 · 发表于 2013-5-22 23:37

小花鹿发表于 2013-5-22 17:09
还记得宿舍分配的那个帖子吧，我用现在的方法又写了一次代码，虽然没有你考虑的全面，但我能基本掌握此类 ...

嗯。宿舍分配，确实原理是很相似的。

这个说明我自己独创的【字典+数组过滤】排除重复的随机算法，还是很有价值的。

好处就在于：
一般人碰到随机不重复要求时，就是很简单地进行：
1. 随机抽
2. 检查重复
  a. 不重复……通过
  b. 重复……goto Retry
3. 抽到最后几个时检查死循环
  a. 能顺利抽完……结束
b. 最后几个有冲突，陷入死循环……goto Redo

…………
实际代码写起来可能比较简单，容易上手……
即使算法效率有问题，但因为一般情况下浪费时间有限（几秒最多十来秒）

于是就从来没有人进一步研究一次性不产生死循环的随机不重复算法了。

目前所知，也就只有你和我两人掌握这个技术了……呵呵。

小花鹿 · 发表于 2013-6-6 13:09

本帖最后由小花鹿于 2013-6-15 12:44 编辑

附件来自本站，放在这里是为了查找方便。

拼音、汉字对照表：

拼音VS汉字.rar (71.66 KB, 下载次数: 54)

字音对照表.rar (71.39 KB, 下载次数: 47)

双字节码表.rar (635.12 KB, 下载次数: 62)

小花鹿 · 发表于 2013-11-15 20:15

选择目录（文件夹）：
Sub test()
Dim fd As FileDialog, f, n&
Set fd = Application.FileDialog(msoFileDialogFolderPicker)
If fd.Show = -1 Then
f = Dir(fd.SelectedItems.Item(1) & "\*.*")
Do While f <> ""
      n = n + 1
      'MsgBox Right("00" & n, 2) & ".rmvb"
      Cells(n, 1) = f
      'Name f As Right("00" & n, 2) & ".rmvb"
      f = Dir
Loop
End If
End Sub

补充内容 (2016-9-8 12:25):
选择文件对话框：
Sub ass()
filenames = Application.GetOpenFilename("EXCEl Files (*.xls*), *.xls*", 0, "选定文件", , False)
MsgBox filenames
End Sub

一只狗三只眼 · 发表于 2014-6-22 17:28

小花鹿发表于 2013-4-19 15:07
以下文章来自本站，放在这里是为了查找方便。

Format函数

和你学习VBA

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

[讨论] 小花鹿学习VBA记录

评分

评分

最新热点 /1