一个奇葩的监考安排

longwin

amzxfgh9632 发表于 2024-4-30 20:51
这样随机安排女+男，男+女，女+女更加合理了，但把考场设成30，基本没有正确的结果

改变了一下算法，重新写了，请测试。[url=]附件[/url]

amzxfgh9632

longwin 发表于 2024-5-3 09:25
改变了一下算法，重新写了，请测试。附件

66666，相当厉害

准提部林

longwin 发表于 2024-5-3 09:25
改变了一下算法，重新写了，请测试。附件

同一考場不可進入兩次或以上//

amzxfgh9632

准提部林 发表于 2024-5-4 10:47
同一考場不可進入兩次或以上//

是的，同一个人监考同一考场多次了

amzxfgh9632

longwin 发表于 2024-5-3 09:25
改变了一下算法，重新写了，请测试。附件

老师您 好，每个监考官只能和每个学生见一次面哦

longwin

确实有问题，已修改，请测试。

[url=]附件[/url]

djk1020

参考了一下本贴高手的算法，原算法是先选再检测，修改后的算法是先剔除再选，这样效率高多了。

奇葩监考安排.rar (27.43 KB, 下载次数: 14)

2024-5-5 11:18 上传

点击文件名下载附件

源码如下：
Option Explicit
Dim i&, j&, k&, m&, n&, strAddr$, Sex$, isSuccess As Boolean
Dim myTotal(1 To 4) As Long
                            'myTotal(1):主监考员数
                            'myTotal(2):监考员总数
                            'myTotal(3):考试科目数
                            'myTotal(4):设置考场数
Dim JKYinfo                 '监考员信息：编号、姓名、性别、累计监考场数
Dim Zkbx$, Fkbx$, Fktemp(1 To 2) As String, myArr
Dim nameList() As String    '监考安排信息：主考官、副考官
Dim bhList() As String      '编号
Dim mySht(1 To 2) As Worksheet
Sub main()
    Dim Max&
    Application.ScreenUpdating = False
    Max = 100                  '重算最大次数
    Set mySht(1) = ActiveWorkbook.Worksheets("监考名单")
    Set mySht(2) = ActiveWorkbook.Worksheets("监考安排")
    With mySht(1)
        myTotal(2) = .Cells(.Rows.Count, 1).End(xlUp).Row - 1
        .Range("D2:D" & (myTotal(2) + 1)).ClearContents
        JKYinfo = .Range("A2:D" & (myTotal(2) + 1))
    End With
    Sex = IIf(MsgBox("主考官是女教师吗？", vbYesNo + vbQuestion) = vbYes, "女", "男")
    Zkbx = ""
    Fktemp(1) = ""
    Fktemp(2) = ""
    For i = 1 To myTotal(2)
        If JKYinfo(i, 3) = Sex Then
            Zkbx = Zkbx & Right("00" & JKYinfo(i, 1), 3) & "|"
        Else
            Fktemp(1) = Fktemp(1) & Right("00" & JKYinfo(i, 1), 3) & "|"
        End If
        Fktemp(2) = Fktemp(2) & Right("00" & JKYinfo(i, 1), 3) & "|"
    Next
    myTotal(1) = UBound(Split(Zkbx, "|"))
    With mySht(2)
        myTotal(3) = (.Cells(2, .Columns.Count).End(xlToLeft).Column - 1) / 2   '考试科目数
        myTotal(4) = .Cells(.Rows.Count, 1).End(xlUp).Row - 2                   '设置考场数
    End With
    If myTotal(1) < myTotal(4) Then
        MsgBox "主监考员不够！"
    Else
        If myTotal(2) < myTotal(4) * 2 Then
            MsgBox "监考员总人数不够！"
        Else
            If myTotal(1) = myTotal(4) Then '只能男女搭配
                Fkbx = Fktemp(1)
            Else
                If myTotal(2) - myTotal(1) >= myTotal(4) Then '提供选择
                    If MsgBox("男女搭配吗？", vbYesNo + vbQuestion) = vbYes Then
                        Fkbx = Fktemp(1)
                    Else
                        Fkbx = Fktemp(2)
                    End If
                Else
                    Fkbx = Fktemp(2)
                End If
            End If
            ReDim bhList(1 To myTotal(4), 1 To myTotal(3) * 2) As String
            n = 0
            Do
                ReDim nameList(1 To myTotal(4), 1 To myTotal(3) * 2) As String
                isSuccess = True
                For i = 1 To myTotal(3)
                    监考安排 i
                    If isSuccess = False Then
                        If n < Max Then
                            For m = 1 To myTotal(2)
                                JKYinfo(m, 4) = 0
                            Next
                        End If
                        Exit For
                    End If
                Next
            Loop While n < Max And isSuccess = False
            '清除内容
            strAddr = "B3:" & mySht(2).Cells(myTotal(4) + 2, 2 * myTotal(3) + 1).Address
            mySht(2).Range(strAddr).ClearContents
            '更新工作表
            If isSuccess = True Then
                mySht(2).Range(strAddr) = nameList
                For i = 1 To myTotal(2)
                    mySht(1).Cells(i + 1, 4).Value = JKYinfo(i, 4)
                Next
            Else
                If MsgBox("已运行了" & n & "次，未找到完全解！写入已安排数据吗？", vbYesNo + vbQuestion) = vbYes Then
                    mySht(2).Range(strAddr) = nameList
                    For i = 1 To myTotal(2)
                        mySht(1).Cells(i + 1, 4).Value = JKYinfo(i, 4)
                    Next
                End If
            End If
        End If
    End If
    Set mySht(1) = Nothing
    Set mySht(2) = Nothing
    Application.ScreenUpdating = True
End Sub
Sub 监考安排(ByVal myNo As Long)
    '先安排一科考试各考场的主考再安排副考官
    Dim ii&, jj&, rndNum&, strBxTemp(1 To 2) As String, strBx$
    strBxTemp(1) = Zkbx
    strBxTemp(2) = Fkbx
    If myNo = 1 Then '第一科监考安排
        For k = 1 To 2
            Randomize
            For j = 1 To myTotal(4)
                myArr = Split(strBxTemp(k), "|")
                rndNum = Int(Rnd * UBound(myArr))
                JKYinfo(CInt(myArr(rndNum)), 4) = JKYinfo(CInt(myArr(rndNum)), 4) + 1
                nameList(j, k) = JKYinfo(CInt(myArr(rndNum)), 2)
                bhList(j, k) = myArr(rndNum)
                strBxTemp(1) = Replace(strBxTemp(1), myArr(rndNum) & "|", "") '从备选库删除本次选出的
                strBxTemp(2) = Replace(strBxTemp(2), myArr(rndNum) & "|", "")
            Next
        Next
    Else
        '选主考
        Randomize
        For j = 1 To myTotal(4)
            strBx = strBxTemp(1)
            For jj = 1 To myNo - 1 '从备选库中剔除本考场前面科目安排过的人
                strBx = Replace(strBx, bhList(j, 2 * jj - 1) & "|", "")
                strBx = Replace(strBx, bhList(j, 2 * jj) & "|", "")
            Next
            If strBx = "" Then
                n = n + 1
                isSuccess = False
                Exit Sub
            Else
                myArr = Split(strBx, "|")
                rndNum = Int(Rnd * UBound(myArr))
                JKYinfo(CInt(myArr(rndNum)), 4) = JKYinfo(CInt(myArr(rndNum)), 4) + 1
                nameList(j, 2 * myNo - 1) = JKYinfo(CInt(myArr(rndNum)), 2)
                bhList(j, 2 * myNo - 1) = myArr(rndNum)
                strBxTemp(1) = Replace(strBxTemp(1), myArr(rndNum) & "|", "") '从备选库删除本次选出的
                strBxTemp(2) = Replace(strBxTemp(2), myArr(rndNum) & "|", "")
            End If
        Next
        '选副考
        Randomize
        For j = 1 To myTotal(4)
            strBx = strBxTemp(2)
            For jj = 1 To myNo - 1
                strBx = Replace(strBx, bhList(j, 2 * jj - 1) & "|", "") '从备选库中剔除本考场前面科目安排过的人
                strBx = Replace(strBx, bhList(j, 2 * jj) & "|", "")
                For ii = 1 To myTotal(4)                                '前面科目安排中与该科该考场主考搭档过的也要从备选库移除
                    If JKYinfo(CInt(bhList(ii, 2 * jj - 1)), 2) = nameList(j, 2 * myNo - 1) Then
                        strBx = Replace(strBx, bhList(ii, 2 * jj) & "|", "")
                    End If
                    If JKYinfo(CInt(bhList(ii, 2 * jj)), 2) = nameList(j, 2 * myNo - 1) Then
                        strBx = Replace(strBx, bhList(ii, 2 * jj - 1) & "|", "")
                    End If
                Next
            Next
            If strBx = "" Then
                n = n + 1
                isSuccess = False
                Exit Sub
            Else
                myArr = Split(strBx, "|")
                rndNum = Int(Rnd * UBound(myArr))
                JKYinfo(CInt(myArr(rndNum)), 4) = JKYinfo(CInt(myArr(rndNum)), 4) + 1
                nameList(j, 2 * myNo) = JKYinfo(CInt(myArr(rndNum)), 2)
                bhList(j, 2 * myNo) = myArr(rndNum)
                strBxTemp(1) = Replace(strBxTemp(1), myArr(rndNum) & "|", "") '从备选库删除本次选出的
                strBxTemp(2) = Replace(strBxTemp(2), myArr(rndNum) & "|", "")
            End If
        Next
    End If
End Sub

djk1020

一般考试不会超过9科，但考场数可能就比较多，如高考考场一般就在100以上。修改后试了一下：150个考场，300监考员，18科考试，很快得到答案。

准提部林

longwin 发表于 2024-5-4 23:21
确实有问题，已修改，请测试。

附件

將5個或更多的[男]改成[女],,,即男女人數不相同, 再測幾次看看,,,
會有重覆配對情形~~~

准提部林

這是配對檢查...放在[监考安排]表執行//
Sub Test_TTT()
Dim Arr, xD, i&, j%, T1$, T2$, X1$, X2$
Set xD = CreateObject("Scripting.Dictionary")
Sheet2.UsedRange.Interior.ColorIndex = 0
Arr = Sheet2.Range("a1").CurrentRegion
For i = 3 To UBound(Arr)
    For j = 2 To UBound(Arr, 2) Step 2
        T1 = Arr(i, j): T2 = Arr(i, j + 1)
        If T1 = "" Or T2 = "" Then GoTo j01
        X1 = T1 & "\" & T2
        X2 = T2 & "\" & T1
        If xD(X1) Then
           Union(Cells(xD(X1) + 2, xD(X1 & "j") + 1).Resize(1, 2), Cells(i + 2, j + 1).Resize(1, 2)).Interior.ColorIndex = 8
        End If
        If xD(X2) Then
           Union(Cells(xD(X2) + 2, xD(X2 & "j") + 1).Resize(1, 2), Cells(i + 2, j + 1).Resize(1, 2)).Interior.ColorIndex = 8
        End If
        xD(X1) = i: xD(X1 & "j") = j
        xD(X2) = i: xD(X2 & "j") = j
j01: Next j
Next i
End Sub