根据要求自动安排监考

nwdslcsg

hnyeke 发表于 2024-12-10 14:54
增加了固定监考场次，固定监考考室和回避监考场次，回避监考考室功能

分两种方式排监考：指定监考场次 ...

试用反馈，有同一名教师出现在同一科目同一考场的情况，比如语文场次，某一考场会出现某教师名字两次的情况，也就是两人监考时，某一考场会是两个一样的教师姓名，还有就是预先指定监考场场次时，会出现有的场次同一名教师姓名出现在不同考场，也就是同时监考两个或多个考场的外情况

nwdslcsg

hnyeke 发表于 2024-12-10 14:54
增加了固定监考场次，固定监考考室和回避监考场次，回避监考考室功能

分两种方式排监考：指定监考场次 ...

还有个小建议，最好做成两个监考员在单独的单元格里。便于手动调整

hnyeke

nwdslcsg 发表于 2024-12-11 23:03
试用反馈，有同一名教师出现在同一科目同一考场的情况，比如语文场次，某一考场会出现某教师名字两次的情 ...

出现冲突可能出现在最后无法排的情况下，把监考老师写在没排的考场，这种情况单元格填充了颜色。
因为没有运用回溯法，有时排到最后就只剩下同一列的空了。

hnyeke

nwdslcsg 发表于 2024-12-12 09:04
还有个小建议，最好做成两个监考员在单独的单元格里。便于手动调整

以前发的两人监考，就是把第1.2安排在一起，3.4安排在一起。

hnyeke

nwdslcsg 发表于 2024-12-11 23:03
试用反馈，有同一名教师出现在同一科目同一考场的情况，比如语文场次，某一考场会出现某教师名字两次的情 ...

有几个地方没更新，试试这个

nwdslcsg

hnyeke 发表于 2024-12-15 20:58
有几个地方没更新，试试这个

试用反馈：确定监考场次的时候，每个考场双人监考，有部分考场出现冲突的现象（同一名老师同时在两个考场监考）

hnyeke

nwdslcsg 发表于 2024-12-17 10:33
试用反馈：确定监考场次的时候，每个考场双人监考，有部分考场出现冲突的现象（同一名老师同时在两个考场 ...

排到最后无法排下去了，暂且写在空处，填充了颜色供手动调节。
正在思考用回溯法排，但写代码不是很精，正在摸索中。

hnyeke

hnyeke 发表于 2024-12-17 10:53
排到最后无法排下去了，暂且写在空处，填充了颜色供手动调节。
正在思考用回溯法排，但写代码不是很精， ...

在网友们的支持下，排监考小程序已基本符合要求，为感谢大家的帮助，现分享在此，供需要的下载使用。

使用中遇到问题，请交流讨论。
谢谢给予帮助的人。

翁知江安

Sub 生成监考表()
Dim i, j, k, m, n, p, q, s, t, a, b, x, xx, zs1, mm, zjz, ss, jc, sc, irow, irow1, icolumn As Integer
Dim ar, tepar1, br, cr
Dim d, d1, d2 As Object
Set d = CreateObject("scripting.dictionary")
Set d1 = CreateObject("scripting.dictionary")
Set d2 = CreateObject("scripting.dictionary")
With Sheets("监考安排")
irow = .[b65536].End(xlUp).Row
icolumn = .[iv1].End(xlToLeft).Column
ar = .[a1].Resize(irow, icolumn)
End With
For i = 11 To irow
  d(i) = ar(i, 2)
Next
irow1 = Sheets("监考安排").[g65536].End(xlUp).Row
For j = 8 To icolumn
   For b = 5 To irow1
     If ar(b, j) = "" Then
        zs1 = zs1 + 1
      End If
  Next
Next
jc = 8
zjz = irow
ReDim tepar1(1 To irow1 - 4, 1 To icolumn - 7)
For m = 8 To icolumn
   t = WorksheetFunction.CountIf(Sheets("监考安排").Cells(1, m).Resize(irow1, 1), "不排监考")
   n = n + irow1 - t - 4
   mm = d.Count
  If irow1 - 4 - t > 0 And n <= zs1 Then
    If mm < irow1 - 4 - t Then
      For s = 1 To irow1 - 4
         If Len(tepar1(s, m - jc - 1)) > 0 Then
           ss = zjz + s
           d(ss) = tepar1(s, m - jc - 1)
         End If
      Next
      zjz = ss
    End If
    ReDim br(1 To irow1 - 4 - t, 1 To 1)
    For p = 1 To irow1 - 4 - t
      mm = d.Count
      q = WorksheetFunction.RandBetween(1, mm)
      x = d.keys()(q - 1)
      tepar1(p, m - 7) = d(x)
      br(p, 1) = d(x)
      d.Remove x
    Next
      
    With Sheets("监考安排")
    For xx = 5 To irow1
      If .Cells(xx, m) <> "不排监考" Then
           a = a + 1
           .Cells(xx, m) = br(a, 1)
      End If
     Next
     End With
   End If
   a = 0
Next
cr = Sheets("监考安排").[a1].Resize(irow, icolumn)
For j = 8 To icolumn
   sc = Val(WorksheetFunction.Substitute(cr(4, j), "分钟", ""))
For k = 5 To irow1
   If cr(k, j) <> "不排监考" Then
   d1(cr(k, j)) = d1(cr(k, j)) + 1
   d2(cr(k, j)) = d2(cr(k, j)) + sc
    End If
Next
Next
For i = 11 To irow
  Sheets("监考安排").Cells(i, 3) = d1(cr(i, 2))
  Sheets("监考安排").Cells(i, 4) = d2(cr(i, 2))
Next
MsgBox "ok"
End Sub

翁知江安

特别说明，目前只是针对每个考场安排一个老师的情况（如安排2个，教师数量偏少，安排比较难，很可能出现连续监考的情况）。另外，在运行程序前，最好清理一下结果区域。从运行结果看，还是没有达到比较均匀的目的，可能是随机的原因。请楼主见谅。