求助不规则考场编排代码

3190496160

Sub 考号()
Dim d As Object
Set d = CreateObject("scripting.dictionary")
With Sheets("考场分布汇总")
    r = .Cells(Rows.Count, 2).End(xlUp).Row
    ar = .Range("a1:c" & r)
End With
For i = 2 To UBound(ar)
    If Trim(ar(i, 1)) <> "" And Trim(ar(i, 3)) <> "" Then
        d(Trim(ar(i, 1))) = d(Trim(ar(i, 1))) + ar(i, 3)
    End If
Next i
With Sheets("考场编排")
    rs = .Cells(Rows.Count, 8).End(xlUp).Row
    .Range("e2:f" & rs + 1) = Empty
    br = .Range("e1:h" & rs)
    m = 1
    For Each k In d.keys
        kc = k
        sl = d(k)
        For s = 1 To sl
            m = m + 1
            br(m, 1) = Format(kc, "00")
            br(m, 2) = Format(s, "00")
        Next s
    Next k
    .Range("e1:h" & rs) = br
End With
MsgBox "ok!"
End Sub

3190496160

考场手工分配模板.rar (22.77 KB, 下载次数: 23)

2023-3-27 17:15 上传

点击文件名下载附件

liutao0987

3190496160 发表于 2023-3-27 17:15

  谢谢，要的就是这个效果，就是没有标注，有点看不懂。我研究研究

3190496160

liutao0987 发表于 2023-3-27 17:26
谢谢，要的就是这个效果，就是没有标注，有点看不懂。我研究研究

论坛是做义务的，不可能给你代码了还帮你把代码注释好，

liutao0987

3190496160 发表于 2023-3-27 17:34
论坛是做义务的，不可能给你代码了还帮你把代码注释好，

嗯，我自己学学，十分感谢

破例

来个公式的

liutao0987

3190496160 发表于 2023-3-27 17:34
论坛是做义务的，不可能给你代码了还帮你把代码注释好，

代码逻辑看懂了，如果考场编排表是乱序不是按表1顺序，能不能实现？

chxw68

纯属练手。

3190496160

liutao0987 发表于 2023-3-28 09:42
代码逻辑看懂了，如果考场编排表是乱序不是按表1顺序，能不能实现？

肯定是可以的，但是，代码逻辑就不是现在的逻辑了，

liutao0987

chxw68 发表于 2023-3-28 10:15
纯属练手。

谢谢，很明了