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循环的用法。
......
联系客服