|
|
Excel VBA：用数组、字典、随机数实现监考安排示例
参考代码：
Sub 自动组合()
Dim arr
Dim i As Long
Dim j As Long
Dim dAll As Object
Dim key
Dim key1
Dim keySwap
Dim idxRnd As Long
Dim dTemp As Object
Dim brr '监考安排数据写入区域
Dim crr
Dim drr
arr = ThisWorkbook.Worksheets("监考名单").UsedRange.Value
Set dAll = CreateObject("Scripting.Dictionary")
Set dTemp = CreateObject("Scripting.Dictionary")
'遍历所有女教师，进行非重复两两组合，存入字典dAll
For i = LBound(arr, 1) + 1 To UBound(arr, 1)
If arr(i, 2) <> "" And arr(i, 3) = "女" Then
For j = LBound(arr, 1) + 1 To UBound(arr, 1)
If arr(j, 2) <> "" And arr(i, 2) <> arr(j, 2) Then
key = arr(i, 2) & "_" & arr(j, 2)
keySwap = arr(j, 2) & "_" & arr(i, 2)
If Not (dAll.Exists(key) Or dAll.Exists(keySwap)) Then
dAll(key) = True
End If
End If
Next j
End If
Next i
'遍历每个考场的每门学科，随机非重复从dAll中抽取4个组合
brr = ThisWorkbook.Worksheets("监考安排").Range("A1:I27").Value
For i = 3 To 27
dTemp.RemoveAll
For Each key In dAll.keys()
dTemp(key) = True
Next key
For j = 1 To 4
idxRnd = WorksheetFunction.RandBetween(0, dTemp.Count - 1)
key = dTemp.keys()(idxRnd)
crr = Split(key, "_")
Select Case WorksheetFunction.RandBetween(0, 1)
Case 0
brr(i, j * 2) = crr(0)
brr(i, j * 2 + 1) = crr(1)
Case 1
brr(i, j * 2) = crr(1)
brr(i, j * 2 + 1) = crr(0)
End Select
dAll.Remove key '删除已经组合过的情况
dTemp.Remove key
'每场考试组合完成，删除两名教官相关的组合
For Each key1 In dTemp.keys()
drr = Split(key1, "_")
If drr(0) = crr(0) Or drr(0) = crr(1) Or drr(1) = crr(0) Or drr(1) = crr(1) Then
dTemp.Remove key1
End If
Next key1
Next j
Next i
'结果写入
ThisWorkbook.Worksheets("监考安排").Range("A1:I27").Value = brr
MsgBox "完成！"
Set dAll = Nothing
Set dTemp = Nothing
End Sub
|
评分
-
1
查看全部评分
-
|
楼主: amzxfgh9632
沪公网安备 31011702000001号 沪ICP备11019229号-2
楼主
发表于 2024-5-1 11:06
