|
|
压缩包里有排监考的，
Sub 监考安排表设置()
' 2024-8-5 晨
' 依据考试场次安排表，设定监考安排表
'
'
If Sheet2.Cells(2, 7).Value > 0 Then
Else
MsgBox "请先设置：参加考试学生总数！！！"
Exit Sub
End If
Sheet3.Activate
Rows("3:66").Delete Shift:=xlUp ' 删除前一次的数据
x2 = 2
Do While Not (IsEmpty(Sheet2.Cells(x2, 4).Value))
Sheet3.Cells(3, x2 + 2).Value = Sheet2.Cells(x2, 4).Value
Sheet3.Cells(4, x2 + 2).Value = Sheet2.Cells(x2, 1) & "(" & Sheet2.Cells(x2, 2) & ")"
x2 = x2 + 1 ' 按《考试场次》表上的考试，设置《监考安排》表的表头
Loop
[A3] = "试场号": [B3] = "试场地点": [C3] = "参试人数"
Range("A3:A4").Merge
Range("B3:B4").Merge
Range("C3:C4").Merge '至此《监考安排》的表头设置完毕！
sn = Sheet2.Cells(2, 7).Value
If sn / 30 = Int(sn / 30) Then ' 这个IF判断计算出多少个试场
i = sn / 30
Else
i = Int(sn / 30) + 1
ws = sn - Int(sn / 30) * 30 ' 尾试场人数，不为0，用于修改参试人数
End If
For r = 1 To i ' 这个循环 完成试场号的编制
Cells(r + 4, 1).Value = "第" & Mid(CStr(100 + r), 2) & "试场"
Cells(r + 4, 3).Value = 30
Next r
If ws > 0 Then
Cells(r + 3, 3).Value = ws
End If
Range(Cells(3, 1), Cells(r + 3, x2 + 1)).Select
添加表格线
Cells.HorizontalAlignment = xlCenter ' 水平居中
Rows("3:" & r + 3).RowHeight = 19.8
MsgBox "《监考安排》表设置完成，请手工填上，各试场的地点，并处理尾试是否合并到上一试场！！！"
End Sub
Sub 排监考()
' 安排思路：1、考试的科目循环，一个学科一个学科地排
' 2、每一学科排监考时，提取《教师名单》中的老师，提取时排除有不监考标记老师
' 3、对提取的教师进行随机排序后，取二人，写入到《监考安排》表上，以至排满，这样应该不会出现冲突！
'
Dim arr
'Randomize ' 对随机数生成器做初始化的动作。
r = Sheet1.UsedRange.Rows.Count
'arr = Sheet1.[A4].CurrentRegion
'Sheet1.[N1].Resize(UBound(arr), 6) = arr
y1 = 2
Do While Not (IsEmpty(Sheet1.Cells(3, y1).Value))
ReDim arr(1 To r, 1 To 2)
i = 1
x1 = 4
Do While Not (IsEmpty(Sheet1.Cells(x1, 1).Value))
If Sheet1.Cells(x1, y1).Value = "" Then
arr(i, 1) = Sheet1.Cells(x1, 1).Value ' 首次为语文可排教师存入数组，后依次为科学、……英语等
i = i + 1
End If
x1 = x1 + 1
Loop
For j = 1 To i - 1
Randomize ' 对随机数生成器做初始化的动作
arr(j, 2) = Rnd(Second(Time))
Next j ' 至此完成一个学科监考老师进入数组并写入随机数
'--开始对数组进行排序处理
Dim temp(1 To 1, 1 To 2)
For m = 1 To i - 2
For n = m + 1 To i - 1
If arr(m, 2) > arr(n, 2) Then ' 升序用“>”，降序用“<”
temp(1, 1) = arr(n, 1)
temp(1, 2) = arr(n, 2) ' 寄存
arr(n, 1) = arr(m, 1)
arr(n, 2) = arr(m, 2) ' 交换
arr(m, 1) = temp(1, 1)
arr(m, 2) = temp(1, 2) ' 寄存的取回，完成交换
End If
Next n
Next m ' 排序结束
'Sheet1.[N1].Resize(i, 2) = arr ' 编写时观察用语句
'--以下开始从数组中取老师，写入对应学科的试场中，成为监考教师
Sheet3.Activate
rn = Sheet3.UsedRange.Rows.Count
kcs = rn - 4 ' 得到考场个数
For m = 1 To kcs
Cells(m + 4, y1 + 2).Value = arr(m, 1) & "；" & arr(m + kcs, 1)
Next m ' 写入学科的监考教师姓名结束
Erase arr
y1 = y1 + 1
Loop
MsgBox "监考安排已完成！！！"
End Sub
Sub 教师监考查看()
' 2024-8-5晚
' 将《监考安排》表转换成按教师查看监考任务的表
'
Sheet4.Activate
Dim arr(1 To 300, 1 To 2), d, m
Set d = CreateObject("scripting.dictionary")
x3 = 5
Do While Not (IsEmpty(Sheet3.Cells(x3, 1).Value))
y3 = 4
Do While Not (IsEmpty(Sheet3.Cells(3, y3).Value))
jk = Sheet3.Cells(x3, y3).Value
xm1 = Split(jk, "；")(0)
xm2 = Split(jk, "；")(1)
If Not d.exists(xm1) Then
m = m + 1
d(xm1) = m
arr(m, 1) = xm1
arr(m, 2) = 1
Else
g = d(xm1)
arr(g, 2) = arr(g, 2) + 1
End If
If Not d.exists(xm2) Then
m = m + 1
d(xm2) = m
arr(m, 1) = xm2
arr(m, 2) = 1
Else
g = d(xm2)
arr(g, 2) = arr(g, 2) + 1
End If
y3 = y3 + 1
Loop
x3 = x3 + 1
Loop
Sheet4.[A5].Resize(m, y3 - 1) = ""
Sheet4.[A5].Resize(m, 2) = arr
'--以上是利用 字典 ，在监考表里提取唯一老师姓名
x4 = 5
Do While Not (IsEmpty(Sheet4.Cells(x4, 1).Value))
xm = Sheet4.Cells(x4, 1).Value
x3 = 5
Do While Not (IsEmpty(Sheet3.Cells(x3, 1).Value))
y3 = 4
Do While Not (IsEmpty(Sheet3.Cells(3, y3).Value))
jkry = Sheet3.Cells(x3, y3).Value
If InStr(1, jkry, xm, 0) > 0 Then
Sheet4.Cells(x4, y3 - 1).Value = Sheet3.Cells(x3, 1).Value & Chr(10) & Sheet3.Cells(x3, 2).Value
End If
y3 = y3 + 1
Loop
x3 = x3 + 1
Loop
x4 = x4 + 1
Loop
End Sub |
|
沪公网安备 31011702000001号 沪ICP备11019229号-2
发表于 2024-12-20 08:14
楼主
