随机安排考场

cai5926270

如何随机安排考场是学校工作中经常碰到的问题。
由于本人VBA的水平有限无法解决。请教各位大佬出手帮忙。
要求：
1.按科类安排监考考场

（1）第一场在理科考场监考的老师只能在安排理科考场监考;理科考场数目可变，

（2）第一场在文科考场监考的老师只能在安排文科考场监考;文科考场数目可变
2.不能监考曾经监考过的考场如图有标记黄色为不符合要求的;
3.每一间考室的两位监考已组合好不需要改变。

yjh_27

结果见课程表

原贴见
监考均衡随机安排_自定义函数  6L
https://club.excelhome.net/thread-1692281-1-1.html
(出处: ExcelHome技术论坛)

liulang0808

楼主能结合附件模拟下结果，并结合结果说明下对应的调整思路

cai5926270

liulang0808 发表于 2024-7-9 07:17
楼主能结合附件模拟下结果，并结合结果说明下对应的调整思路

好的，感谢

cai5926270

1.不需要那么复杂，只需要每组监考（已组合好一直不变是这两位老师）下一场监考的考室不能是曾经监考过的考场就可以了

gwjkkkkk

Option Explicit
Sub TEST7()
    Dim ar, br, i&, j&, dic As Object, vKey
   
    Application.ScreenUpdating = False
    Set dic = CreateObject("Scripting.Dictionary")

    ar = [A1].CurrentRegion.Value
    For i = 3 To UBound(ar)
        dic(ar(i, 3)) = dic(ar(i, 3)) & " " & i
    Next i
   
    For Each vKey In dic.keys
        br = Split(dic(vKey))
        For j = 4 To UBound(ar, 2)
            arrGetRnd1 br
            For i = 1 To UBound(br)
                ar(br(i), j) = i
            Next i
        Next j
    Next
   
    [A1].Resize(UBound(ar), UBound(ar, 2)) = ar
    Set dic = Nothing
    Application.ScreenUpdating = True
End Sub

Function arrGetRnd1(ByRef ar)
    Dim xNum&, i&, n&, vTemp
    Randomize
    n = UBound(ar)
    For i = 1 To UBound(ar)
        xNum = Int((n - i + 1) * Rnd() + i)
        vTemp = ar(xNum): ar(xNum) = ar(i): ar(i) = vTemp
    Next
End Function

gwjkkkkk

。。。。。。。。

yjh_27

cai5926270 发表于 2024-7-9 18:25
1.不需要那么复杂，只需要每组监考（已组合好一直不变是这两位老师）下一场监考的考室不能是已监考过的考场 ...

这个简单，就是将6个数、4个数随机洗4遍

cai5926270

yjh_27 发表于 2024-7-9 20:12
这个简单，就是将6个数、4个数随机洗4遍

考室数量不定

cai5926270

gwjkkkkk 发表于 2024-7-9 18:46
。。。。。。。。

每组监考老师不能再监考他们曾经监考过的考场，有标记黄色的都不符合要求