Excel VBA 学校老师监考考场自动按排

https://www.toutiao.com/article/7288918042447462971/?log_from=f7c4ce41dba13_1697216170226

本文于2023年8月31日首发于本人同名公众号：Excel活学活用，更多文章案例请搜索关注！

内容提要

• 老师任教堂次统计
• 根据规则安排考场
• 监考老师安排结果冲突检查

大家好，我是冷水泡茶，前两天有公众号粉丝朋友给我派了一活，请我帮忙安排监考老师：

他的原始数据是这样的，是一个教师任课表，有老师在1~3个班任教，一共有30多个班，90多位老师：

考试科目安排如下，两天共6场：

他的要求是，根据老师的任课堂次安排监考次数，并且要安排在其任教的某一个班级考场，而且班主任要安排在本班考场，就如上图所示，

开始我觉得这应该不算太难吧？正好前面我们有一篇关于老师任课数量的统计【Excel VBA 从总课表汇总出每名教师任教情况/相同内容单元格突出显示】正好可以拿来一用。

然而，搞了几天，总是不能将任课老师按照他的任课次数安排监考次数，并且还要安排在他任教的任意一个班级。也许，这样的组合可能就是一个无解，当然，也可能是我的道行太浅。

我提出就按照课表就地安排，调整一下监考次序，应该能安排：

他还是坚持要连续安排，这也好理解，让监考老师少跑腿，如果校园很大，或者分为几个校区，那必须这样安排。但是，预定的规则给了很大限制，想尽办法，仍然不能完美安排，总有几个班空着，而剩下几位老师并不在这些班任教。最终，他还是给出了妥协的方案：

说到底，就是把剩下没有办法安排的随便找个空位排进去，我试了一下，总算排满了，终于可以长出一口气了，我们一起来看看吧：

基本思路

1、任教课程数统计，这个可以参考前文提及的方法，列出老师、任课次数，任教班级及课程等，这里有个“班主任“的问题，也把它列到任教课程里，在后面安排的时候作为一个判断条件。

2、我们把每一个教师可能安排的班级及监考次数列出一个表，每个班每次监考一条记录，并且标注监考次数（比如，一班|李老师|1;一班|李老师|2;一班|李老师|3;三班|李老师|1;三班|李老师|2;三班|李老师|3;）在后续安排的时候，每填一个监考位置，我们就把相应的非本班的这个老师的记录删除，避免重复安排。

3、在安排的时候，先把“班主任”安排到各个考场的开始位置，可能是1次、2次或3次。

4、接着，把已安排了3次的考场，去寻找该考场对应的监考老师中正好是3次的记录，正好安排满。如果没有3次的，安排1次。

5、然后，寻找仅安排1次的考场，安排1次或3次的监考老师。

6、下一步，根据选项，如果是“班级优先“（尽量在任教班级里连续安排），我们仍然按照对应班级去安排一下，再进行最后的不按班级随机安排；如果是“连续优先”（优先连续安排在一个考场，除了班主任，可以不考虑任教班级），那就直接进行最后的不按班级随机安排。

7、最后，检查安排结果有没有时间冲突的，即纵向同一监考时段不能有重复的监考老师。

程序代码

1、模块myModul，ClassAndSubject过程，任教堂次统计：

Public ArrangeType As String
Sub ClassAndSubject()
    Dim arr(), arrResult()
    Dim Dic As Object
    Dim lastRow As Integer
    Dim wsSource As Worksheet
    ThisWorkbook.Activate
    Set Dic = CreateObject("scripting.dictionary")
    Set wsSource = ThisWorkbook.Sheets("教师安排表")
    With wsSource
        lastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
        arr = .Range("A2:K" & lastRow)
    End With
    For i = 2 To UBound(arr)
        For j = 2 To UBound(arr, 2)
            If Len(arr(i, j)) <> 0 Then
                If Not Dic.exists(arr(i, j)) Then
                    ReDim arrResult(1 To 5)
                    arrResult(1) = arr(i, j)
                    arrResult(4) = arr(i, 1)
                Else
                    arrResult = Dic(arr(i, j))
                    If arr(1, j) = "班主任" Then
                        arrResult(4) = arr(i, 1)
                    End If
                End If
                arrResult(2) = arrResult(2) + 1
                arrResult(3) = arrResult(3) & "[" & arr(i, 1) & "]" & arr(1, j) & "/"
                arrResult(5) = arrResult(5) & arr(i, j) & "/"
                Dic(arr(i, j)) = arrResult
            End If
        Next
    Next
    arr = Dic.items
    For i = 0 To UBound(arr)
        If InStr(arr(i)(3), "班主任") > 0 And arr(i)(2) > 1 Then
            arr(i)(5) = Left(arr(i)(5), Len(arr(i)(5)) - Len(arr(i)(1)) - 1)
            arr(i)(2) = arr(i)(2) - 1
        End If
    Next
    With wsSource
        .Range("O2").Resize(.UsedRange.Rows.Count, .UsedRange.Columns.Count).ClearContents
        .Range("O2").Resize(Dic.Count, 5) = Application.Transpose(Application.Transpose(arr))
    End With
End Sub

‍

代码解析：

（1）定义一些变量，工作表对象ws，数组，字典。过程外定义了一个公有变量ArrangeType，安排类型，用于后面过程的条件判断。

（2）line10~13，把教师安排表装入数组。

（3）line14~33，循环数组，统计任教堂次，设置任教班级+老师的字符串等信息，以一个数组的形式赋值给字典的item。

（4）line34~40，把字典的item赋值给数组arr，对包含“班主任”的记录进行处理，任教次数减去1次。

（5）line41~44，把结果写入“教师安排表”。

2、模块myModul，SuperviseExam过程，监考安排：

Sub SuperviseExam()
    'On Error Resume Next
    Dim arr(), arrResult(), arrArrange(), arrTem()
    Dim Dic As Object
    Dim lastRow As Integer
    Dim wsSource As Worksheet
    Dim wsDest As Worksheet
    Dim strArrange As String
    Dim strClass As String
    Call ClassAndSubject
    ThisWorkbook.Activate
    Set Dic = CreateObject("scripting.dictionary")
    Set wsSource = ThisWorkbook.Sheets("教师安排表")
    With wsSource
        lastRow = .UsedRange.Rows.Count
        arr = .Range("O2:T" & lastRow)
    End With
    Set wsDest = ThisWorkbook.Sheets("监考安排表")
    With wsDest
        lastRow = .UsedRange.Rows.Count
        .Range("B11:G" & lastRow).ClearContents
        arrResult = .Range("A11:G" & lastRow)
    End With
     
    For j = 1 To UBound(arrResult)
        strClass = "[" & j & "]"
        For i = 1 To UBound(arr)
            If InStr(arr(i, 3), "班主任") Then
                If InStr(arr(i, 3), strClass & "班主任") Then
                    If arr(i, 2) > 1 Then
                        For h = 1 To arr(i, 2)
                            ReDim Preserve arrArrange(0 To 4, 0 To k)
                            arrArrange(0, k) = j
                            arrArrange(1, k) = arr(i, 1)
                            arrArrange(2, k) = "班主任"
                            arrArrange(3, k) = arr(i, 2)
                            arrArrange(4, k) = arr(i, 4)
                            k = k + 1
                            '
                        Next
                    Else
                        ReDim Preserve arrArrange(0 To 4, 0 To k)
                        arrArrange(0, k) = j
                        arrArrange(1, k) = arr(i, 1)
                        arrArrange(2, k) = "班主任"
                        arrArrange(3, k) = arr(i, 2)
                        arrArrange(4, k) = arr(i, 4)
                        k = k + 1
                     End If
                End If
            ElseIf InStr(arr(i, 3), strClass) Then
                For h = 1 To arr(i, 2)
                    ReDim Preserve arrArrange(0 To 4, 0 To k)
                    arrArrange(0, k) = j
                    arrArrange(1, k) = arr(i, 1)
                    arrArrange(2, k) = h
                    arrArrange(3, k) = arr(i, 2)
                    arrArrange(4, k) = arr(i, 4)
                    k = k + 1
                Next
            End If
        Next
    Next


    '填班主任
     For i = 1 To UBound(arrResult)
        k = 0
        If arrResult(i, 1) <> "" Then
            For h = 0 To UBound(arrArrange, 2)
                If arrArrange(0, h) = arrResult(i, 1) And arrArrange(2, h) = "班主任" Then
                    arrResult(i, k + 2) = arrArrange(1, h)
                    arrArrange(3, h) = ""
                    k = k + 1
                End If
            Next
        End If
    Next


    '预填,先填3堂次的
    For i = 1 To UBound(arrResult)
        k = 0
        blank = 0
        If arrResult(i, 1) <> "" Then
            For j = 2 To 7
                If arrResult(i, j) = "" Then
                    blank = blank + 1
                End If
            Next
            If blank = 3 Then
                For j = 2 To 7
                    If arrResult(i, j) = "" Then
                        For h = 0 To UBound(arrArrange, 2)
                            If arrArrange(0, h) = arrResult(i, 1) And arrArrange(3, h) = 3 Then
                                arrResult(i, j) = arrArrange(1, h)
                                temp = arrArrange(1, h) & arrArrange(2, h)
                                arrArrange(3, h) = ""
                                temp1 = arrArrange(3, h)
                                Exit For
                            End If
                        Next
                        '其他班标注不排
                        For h = 0 To UBound(arrArrange, 2)
                            If arrArrange(1, h) & arrArrange(2, h) = temp Then
                                arrArrange(3, h) = temp1
                            End If
                        Next
                    End If
                Next
            End If
        End If
    Next
     
    '预填,再查找余下已安排3次，选择另一个1次安排
    For i = 1 To UBound(arrResult)
        k = 0
        blank = 0
        If arrResult(i, 1) <> "" Then
            For j = 2 To 7
                If arrResult(i, j) = "" Then
                    blank = blank + 1
                End If
            Next
            If blank = 3 Then
                For j = 2 To 7
                    If arrResult(i, j) = "" Then
                        For h = 0 To UBound(arrArrange, 2)
                            If arrArrange(0, h) = arrResult(i, 1) And arrArrange(3, h) = 1 Then
                                arrResult(i, j) = arrArrange(1, h)
                                temp = arrArrange(1, h) & arrArrange(2, h)
                                arrArrange(3, h) = ""
                                temp1 = arrArrange(3, h)
                                Exit For
                            End If
                        Next
                        '其他班标注不排
                        For h = 0 To UBound(arrArrange, 2)
                            If arrArrange(1, h) & arrArrange(2, h) = temp Then
                                arrArrange(3, h) = temp1
                            End If
                        Next
                    End If
                Next
            End If
        End If
    Next


    '预填,再填仅安排了1次的，选择另一个1次或3次安排
    For i = 1 To UBound(arrResult)
        k = 0
        blank = 0
        If arrResult(i, 1) <> "" Then
            For j = 2 To 7
                If arrResult(i, j) = "" Then
                    blank = blank + 1
                End If
            Next
            If blank = 5 Then
                For j = 2 To 7
                    If arrResult(i, j) = "" Then
                        For h = 0 To UBound(arrArrange, 2)
                            If arrArrange(0, h) = arrResult(i, 1) And (arrArrange(3, h) = 1 Or arrArrange(3, h) = 3) Then     '
                                arrResult(i, j) = arrArrange(1, h)
                                temp = arrArrange(1, h) & arrArrange(2, h)
                                arrArrange(3, h) = ""
                                temp1 = arrArrange(3, h)
                                Exit For
                            End If
                        Next
                        '其他班标注不排
                        For h = 0 To UBound(arrArrange, 2)
                            If arrArrange(1, h) & arrArrange(2, h) = temp Then
                                arrArrange(3, h) = temp1
                            End If
                        Next
                    End If
                Next
            End If
        End If
    Next
     
    '如果是"班级优先",仍按照班级填
    If ArrangeType = "班级优先" Then
        For i = 1 To UBound(arrResult)
            k = 0
            If arrResult(i, 1) <> "" Then
                For j = 2 To 7
                    '填班其他,填一个
                    If arrResult(i, j) = "" Then
                        For h = 0 To UBound(arrArrange, 2)
                            If arrArrange(0, h) = arrResult(i, 1) And arrArrange(3, h) <> "" Then
                                arrResult(i, j) = arrArrange(1, h)
                                temp = arrArrange(1, h) & arrArrange(2, h)
                                arrArrange(3, h) = ""
                                temp1 = arrArrange(3, h)
                                Exit For
                            End If
                        Next
                        '其他班标注不排
                        For h = 0 To UBound(arrArrange, 2)
                            If arrArrange(1, h) & arrArrange(2, h) = temp Then
                                arrArrange(3, h) = temp1
                            End If
                        Next
                    End If
                Next
            End If
        Next
    End If
     
    '余下的不对应任教班级
    For i = 1 To UBound(arrResult)
        If arrResult(i, 1) <> "" Then
            For j = 2 To 7
                '填班其他,填一个
                If arrResult(i, j) = "" Then
                    For h = 0 To UBound(arrArrange, 2)
                        If arrArrange(3, h) <> "" Then
                            arrResult(i, j) = arrArrange(1, h)
                            temp = arrArrange(1, h) & arrArrange(2, h)
                            arrArrange(3, h) = ""
                            temp1 = arrArrange(3, h)
                            Exit For
                        End If
                    Next
                    '其他班标注不排
                    For h = 0 To UBound(arrArrange, 2)
                        If arrArrange(1, h) & arrArrange(2, h) = temp Then
                            arrArrange(3, h) = temp1
                        End If
                    Next
                End If
            Next
        End If
    Next


    With wsDest
        .Range("A11").Resize(.UsedRange.Rows.Count, 7).ClearContents
        .Range("A11").Resize(UBound(arrResult), 7) = arrResult
    End With
End Sub

代码解析：

（1）代码很长，基本过程如前面“基本思路“中所述。下面简要说明。

（2）把所有可能的监考场次排列出来，存到数组arrArrange中。

（3）然后循环结果数组，按考场，逐次到arrArrange数组中寻找符合条件的记录，找到一个填到结果数组中，接着就把其他考场中该老师的记录删除一条。

（4）先填班主任老师的监考安排，然后再根据不同条件进行安排。

（5）如果不考虑班主任必须安排在本班，可以在“教师安排表”中把“班主任”那一列清空。

（6）把结果数组写入“监考安排表”。

3、模块myModul，ConflictCheck过程，冲突检查：

Sub ConflictCheck()
    '监考安排表竖向重复的调整
    Dim arr(), arrTem()
    Dim lastRow As Integer
    Dim wsDest As Worksheet
    Dim str As String
    Set wsDest = ThisWorkbook.Sheets("监考安排表")
    With wsDest
        lastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
        arrTem = .Range("A11:G" & lastRow)
    End With
    M = 0
    y = 0
    Do While y < 10  '最多运行检查10次，如果超过10次仍有空白的，退出。
    For i = 3 To 7
        For j = 2 To UBound(arrTem)
            If arrTem(j, i) <> "" Then
                str = str & arrTem(j - 1, i) & "/"
                str = "/" & str
                If InStr(str, "/" & arrTem(j, i) & "/") Then
                    temp = arrTem(j, i)
                    Debug.Print j & "|" & i & ":" & temp
                    If i = 7 Then
                        arrTem(j, i) = arrTem(j, i - 1)
                        arrTem(j, i - 1) = temp
                    Else
                        arrTem(j, i) = arrTem(j, i + 1)
                        arrTem(j, i + 1) = temp
                    End If
                End If
            End If
        Next
        str = ""
    Next
    '再检查重复
    For i = 3 To 7
        For j = 2 To UBound(arrTem)
            If arrTem(j, i) <> "" Then
                str = str & arrTem(j - 1, i) & "/"
                str = "/" & str
                If InStr(str, "/" & arrTem(j, i) & "/") Then
                    M = 1
                End If
            End If
        Next
        str = ""
    Next
    
    If M = 1 Then
        For i = 3 To 7
            For j = UBound(arrTem) - 1 To 1 Step -1
                If arrTem(j, i) <> "" Then
                    str = str & arrTem(j + 1, i) & "/"
                    str = "/" & str
                    If InStr(str, "/" & arrTem(j, i) & "/") Then
                        temp = arrTem(j, i)
                        Debug.Print j & "|" & i & ":" & temp
                        If i = 7 Then
                            arrTem(j, i) = arrTem(j, i - 1)
                            arrTem(j, i - 1) = temp
                        Else
                            arrTem(j, i) = arrTem(j, i + 1)
                            arrTem(j, i + 1) = temp
                            
                        End If
                    End If
                End If
            Next
            str = ""
        Next
        '再检查重复
        For i = 3 To 7
            For j = 2 To UBound(arrTem)
                If arrTem(j, i) <> "" Then
                    str = str & arrTem(j - 1, i) & "/"
                    str = "/" & str
                    If InStr(str, "/" & arrTem(j, i) & "/") Then
                        M = 1
                    End If
                End If
            Next
            str = ""
        Next
        
    End If
    
    '再跟左边交换
    For i = 3 To 7
        For j = 2 To UBound(arrTem)
            If arrTem(j, i) <> "" Then
                str = str & arrTem(j - 1, i) & "/"
                str = "/" & str
                If InStr(str, "/" & arrTem(j, i) & "/") Then
                    temp = arrTem(j, i)
                    Debug.Print j & "|" & i & ":" & temp
                    If i = 1 Then
                        arrTem(j, i) = arrTem(j, i + 1)
                        arrTem(j, i - 1) = temp
                    Else
                        arrTem(j, i) = arrTem(j, i - 1)
                        arrTem(j, i + 1) = temp
                        
                    End If
                End If
            End If
        Next
        str = ""
    Next
    '再检查重复
    For i = 3 To 7
        For j = 2 To UBound(arrTem)
            If arrTem(j, i) <> "" Then
                str = str & arrTem(j - 1, i) & "/"
                str = "/" & str
                If InStr(str, "/" & arrTem(j, i) & "/") Then
                    M = 1
                End If
            End If
        Next
        str = ""
    Next
    
    If M = 0 Then
        y = 10
    Else
        
        y = y + 1
    End If
    Loop
    With wsDest
        .Range("A11").Resize(.UsedRange.Rows.Count, 7).ClearContents
        .Range("A11").Resize(UBound(arrTem), 7) = arrTem
        .Activate
    End With
End Sub

代码解析：

（1）在初次安排完成后，有可能存在冲突记录，即一名老师在同一监考时段安排了两次或以上。

（2）把监考安排记录读入数组arrTem。

（3）然后纵向循环数组，把第一行到上一行的老师姓名连成一个字符串str，检查当前单元格老师是否包括在str中，如果包括，则说明当前单元格是重复记录，就把它与右边的记录调换位置，如果是最右边的记录，则与左边记录调换位置。

（4）完成一轮后，再从头检查是否有重复记录。如果有，使得M=1，然后y=y+1，如果没有，则M应该为0，使得y=10。这里用了一个Do while循环，如果y<10则继续执行冲突检查，如果检查了10次，仍有冲突记录，则退出，避免无限循环。第二轮从下往上循环，第三轮跟左边记录交换。

4、其他过程：监考安排表中的命令安钮：

Private Sub CmdConflictCheck_Click()
    Call ConflictCheck
End Sub


Private Sub CmdSuperviseExam1_Click()
    ArrangeType = "班级优先"
    SuperviseExam
End Sub


Private Sub CmdSuperviseExam2_Click()
    ArrangeType = "连续优先"
    SuperviseExam
End Sub

Tips

1、数组作为字典的Item方法。

2、根据一条记录对应的数字a，构造出a条同样的记录，就是在我们生成arrArrange数组（监考安排）中所使用的方法。

3、Do While循环的用法。

......