|
|
VBA代码：
Option Explicit
Dim myTotal(1 To 4) As Long
'myTotal(1):女监考员数
'myTotal(2):监考员总数
'myTotal(3):考试科目数
'myTotal(4):设置考场数
Dim i&, j&, k&, m&, strAddr$
Dim Limit& '监考场数上限
Dim mySht(1 To 2) As Worksheet
Dim flagInfo() As String '监考员信息：姓名、本科目选中标记、累计监考场数
Dim nameList() As String '监考安排信息：主考官（女）、副考官
Sub main()
'监考安排
Application.ScreenUpdating = False
Set mySht(1) = ActiveWorkbook.Worksheets("监考名单")
Set mySht(2) = ActiveWorkbook.Worksheets("监考安排")
With mySht(1)
myTotal(2) = .Cells(.Rows.Count, 1).End(xlUp).Row - 1 '监考员总数
ReDim flagInfo(1 To myTotal(2), 1 To 3) As String
'数据整理：按性别降序排列
strAddr = "B1:C" & (myTotal(2) + 1) '排序区域
.Range(strAddr).Sort Key1:=.Range("C2"), Order1:=xlDescending, Header:=xlYes, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, SortMethod _
:=xlPinYin, DataOption1:=xlSortNormal
'数组赋初值
myTotal(1) = 0
For i = 1 To myTotal(2)
If .Cells(i + 1, 3).Value = "女" Then
myTotal(1) = myTotal(1) + 1 '统计女监考员人数
flagInfo(i, 1) = .Cells(i + 1, 2).Value
flagInfo(i, 2) = ""
flagInfo(i, 3) = 0
Else
Exit For
End If
Next
For j = i To myTotal(2)
flagInfo(j, 1) = .Cells(j + 1, 2).Value
flagInfo(j, 2) = ""
flagInfo(j, 3) = 0
Next
End With
With mySht(2)
myTotal(4) = .Cells(.Rows.Count, 1).End(xlUp).Row - 2 '设置考场数
myTotal(3) = (.Cells(2, .Columns.Count).End(xlToLeft).Column - 1) / 2 '考试科目数
End With
If myTotal(1) < myTotal(4) Then
MsgBox "女监考员不够！"
Else
If myTotal(2) < myTotal(4) * 2 Then
MsgBox "监考员总人数不够！"
Else
ReDim nameList(1 To myTotal(4), 1 To myTotal(3) * 2) As String
Limit = -Int(-myTotal(4) * myTotal(3) * 2 / myTotal(2))
For i = 1 To myTotal(3)
监考安排名单 i
Next
'更新工作表
With mySht(2)
strAddr = "B3:" & .Cells(myTotal(4) + 2, 2 * myTotal(3) + 1).Address
.Range(strAddr).ClearContents
.Range(strAddr) = nameList
End With
End If
End If
Set mySht(1) = Nothing
Set mySht(2) = Nothing
Application.ScreenUpdating = True
End Sub
Sub 监考安排名单(ByVal myNo As Long)
'=======================================================
'要求解读：
' 1、“随机”不随俗；
' 2、要想好，先有“女”--每组必有一名“女”考官；
' 3、相逢不可曾相识；
' 4、故地不重游；
' 5、莫让伊人独憔悴--监考场次尽量匀衡。
'=======================================================
Dim ii&, jj&, mmm&, rndMin&, rndMax&, rndNum&, isTest As Boolean
Randomize
For k = 1 To 2 '主、副两名考官
' '主考官为女
' If k = 1 Then
' rndMin = 0
' rndMax = myTotal(1)
' Else
' rndMin = myTotal(1)
' rndMax = myTotal(2) - myTotal(4)
' End If
'男女搭配
If k = 1 Then
rndMin = 0
rndMax = myTotal(1)
Else
rndMin = myTotal(1)
rndMax = myTotal(2) - myTotal(1)
End If
For j = 1 To myTotal(4)
m = 0
Do
m = m + 1
'产生随机数
Do
rndNum = rndMin + Int(Rnd * rndMax) + 1
If rndNum > myTotal(2) Then
rndNum = rndNum - myTotal(2)
mmm = 0
For ii = 1 To myTotal(1)
If flagInfo(ii, 2) = "" Then
mmm = mmm + 1
If mmm = rndNum Then
rndNum = ii
Exit For
End If
End If
Next
End If
Loop Until flagInfo(rndNum, 2) = ""
'条件检测
isTest = True
If myNo > 1 Then
For ii = 1 To myNo - 1
If flagInfo(rndNum, 1) = nameList(j, 2 * ii - 1) Or flagInfo(rndNum, 1) = nameList(j, 2 * ii) Then
isTest = False '“故地不重游”检测未通过
Exit For
End If
Next
If isTest = True And k > 1 Then
For ii = 1 To myNo - 1
For jj = 1 To myTotal(4)
If nameList(j, 2 * myNo - 1) & flagInfo(rndNum, 1) = nameList(jj, 2 * ii - 1) & nameList(jj, 2 * ii) Or _
nameList(j, 2 * myNo - 1) & flagInfo(rndNum, 1) = nameList(jj, 2 * ii) & nameList(jj, 2 * ii - 1) Then
isTest = False '“相逢不可曾相识”检测未通过
Exit For
End If
Next
If isTest = False Then
Exit For
End If
Next
End If
End If
Loop While ((isTest = False) Or (flagInfo(rndNum, 3) + 0 = Limit)) And (m < 100)
'赋值
If m < 100 Then
flagInfo(rndNum, 2) = "√"
flagInfo(rndNum, 3) = flagInfo(rndNum, 3) + 1
nameList(j, 2 * (myNo - 1) + k) = flagInfo(rndNum, 1)
End If
Next
Next
'清除标记
For ii = 1 To myTotal(2)
flagInfo(ii, 2) = ""
Next
End Sub
|
|
楼主: amzxfgh9632
沪公网安备 31011702000001号 沪ICP备11019229号-2
楼主
发表于 2024-4-24 14:37
