|
|
- Public Sub X2()
- ' 定义变量
- Dim proc_own, proc_count, teacher_proc_times, room_proc_times, proc_rnd
- ' 代码从这里开始写
- ' 声明变量eRow，eCol存储末行行号和末列列号
- Dim eRow As Long, eCol As Long
- ' 声明工作簿变量wb和工作表变量sht
- Dim wb As Workbook, sht As Worksheet
- ' 设置wb为当前工作簿
- Set wb = Application.ThisWorkbook
- ' 声明工作表对象变量pSht
- Dim pSht As Worksheet
- ' 设置sht为指定名称的工作表，引号内填写工作表名称
- Set sht = wb.Worksheets(1)
- ' 设置psht为工作表，在引号内填写工作表名称
- Set pSht = wb.Worksheets(2)
- ' 声明名为d的变量
- Dim dTeacherOfClass As Object
- Dim dRoom, dTeacher, dSubject
- ' 创建字典用来保存验证条件
- Set dTeacher = CreateObject("Scripting.Dictionary")
- Set dSubject = CreateObject("Scripting.Dictionary")
- Set dRoom = CreateObject("Scripting.Dictionary")
- ' 创建一个字典d
- Set dTeacherOfClass = CreateObject("Scripting.Dictionary")
- ' 使用With语句，方便对工作表Sht进行多次操作
- With sht
- '读取参数
- If .Range("j2").Value = "任教班级" Then
- proc_own = True
- Else
- proc_own = False
- End If
- teacher_proc_times = .Range("j3").Value
- room_proc_times = .Range("j4").Value
- proc_count = .Range("j5").Value
- If .Range("j6").Value = "是" Then
- proc_rnd = True
- Else
- proc_rnd = False
- End If
- ' 设置范围为从A2开始的当前区域
- Set Rng = .Range("A2").CurrentRegion
- ' 将范围Rng的值赋给数组Arr
- arr = Rng.Value
- ' 变量 i 从数组Arr第一维 最小索引开始，遍历至最大索引
- ' 变量 j 从数组Arr第二维 最小索引开始，遍历至最大索引
- For i = 2 To UBound(arr)
- For j = 2 To UBound(arr, 2)
- Key = arr(i, 1)
- '按班级分工串接教师姓名
- dTeacherOfClass(Key) = dTeacherOfClass(Key) & "-" & arr(i, j) '串接教师姓名
- '初始化教师个人已安排监考次数为0
- dTeacher(arr(i, j)) = 0
- Next j
- Next i
- End With
- With pSht
- ' 获取列A中最大数据行的行号
- eRow = .Cells(.Rows.Count, 1).End(xlUp).Row
- ' 获取第1行中最右侧数据列的列号
- eCol = .Cells(1, .Columns.Count).End(xlToLeft).Column
- .UsedRange.Offset(1, 1).ClearContents
- '循环每一个考场地点
- For i = 2 To eRow Step 1
- '读取考场地点
- cls = .Cells(i, 1).Value
- '任教班级监考 把任教班级的教师放入数组ar
- If proc_own Then
- ar = Split(Mid(dTeacherOfClass(cls), 2), "-")
- Else
- '不限制 所有教师放入数组ar
- 's = ""
- 'For Each k In dTeacherOfClass
- ' s = s & dTeacherOfClass(k)
- 'Next
- 'ar = Split(Mid(s, 2), "-")
- ar = dTeacher.keys
- End If
-
-
- '循环每个监考科目
- For j = 2 To eCol
- '读取科目名称
- sbj = .Cells(1, j).Value
- '是否打乱顺序
- If proc_rnd Then
- br = RndArr(ar)
- Else
- br = ar
- End If
- '开始挑选老师 初始化名单s为空
- s = ""
- For n = 1 To proc_count '几人监考
- '遍历名单中的每个教师姓名
- For Each t In br
- '串接考场与教师姓名，初始化该考场某教师的监考次数
- If dRoom.exists(cls & t) = False Then dRoom(cls & t) = 0
- '筛选条件 统一考点不超过次数， 同一科目不同考场同一教师不能同时监考 ，教师个人监考次数上限不超过次数
- If dRoom(cls & t) < room_proc_times And dSubject.exists(sbj & t) = False And dTeacher(t) <= teacher_proc_times Then
- '构建名单
- s = IIf(s = "", t, s & "-" & t)
- '更新检验条件
- dRoom(cls & t) = dRoom(cls & t) + 1 '该考场 某老师监考次数+1
- dSubject(sbj & t) = 1 '该科目 某教师监考次数为1
- dTeacher(t) = dTeacher(t) + 1 '教师个人监考次数+1
- Exit For '退出循环
- End If
- Next t
- Next n
- '输出名单
- .Cells(i, j).Value = s
- Next j
- Next i
- End With
- End Sub
- ' 打乱数组元素 把教师姓名顺序打乱
- Function RndArr(ByVal ar)
- ' 循环每一个元素
- For i = 1 To UBound(ar)
- ' 随机产生一个索引范围内的数字
- y = Int(Rnd * (UBound(ar)) + 1)
- ' 交换当前元素和随机下标的元素
- tmp = ar(y)
- ar(y) = ar(i)
- ar(i) = tmp
- Next i
- ' 传回数组
- RndArr = ar
- End Function
|
评分
-
1
查看全部评分
-
|
楼主: 不规则结构
/1 
沪公网安备 31011702000001号 沪ICP备11019229号-2
发表于 2024-6-13 10:26
楼主
