|
|
Sub t()
arr = ThisWorkbook.Sheets("考场号和座位号安排").Range("A2:D2").Resize(Cells(Rows.Count, 1).End(xlUp).Row - 1, 4).Value
To_Keys = keys(arr, 3)
For i = LBound(To_Keys) To UBound(To_Keys)
brr = FilterArray2D(arr, To_Keys(i), 3)
brr = ShuffleArray2D(brr)
Call 生成准考证号码(brr, 4)
Next i
End Sub
Private Sub 生成准考证号码及排座位(ByRef arr As Variant, ByVal col As Integer)
考生人数 = UBound(arr, 1)
考场数 = Application.WorksheetFunction.RoundUp(考生人数 / 30, 0)
考点编号 = Format(ExtractNumbers(arr(1, 3)), "00")
Set ws = ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
k = 1: n = 1
Dim brr As Variant: Dim temparr As Variant
For i = 1 To 考场数
ReDim temparr(1 To 30): ReDim brr(1 To 10, 1 To 4)
For j = 1 To 30
If k > 考生人数 Then Exit For
arr(k, 4) = 考点编号 & Format(i, "00") & Format(j, "00")
temparr(j) = arr(k, 2) & "," & arr(k, 3) & "," & arr(k, 4)
k = k + 1
Next j
l = 1
For y = 4 To 1 Step -1
Dim startX As Integer, endX As Integer, stepX As Integer
startX = 3
endX = IIf(y >= 3, 10, 9)
If y Mod 2 = 0 Then
stepX = 1
Else
stepX = -1: Call Swap(startX, endX)
End If
For x = startX To endX Step stepX
brr(x, y) = temparr(l): l = l + 1
Next x
Next y
brr(1, 1) = "第" & i & "考场开始座位安排": brr(2, 1) = "前门": brr(2, 2) = "讲台": brr(10, 1) = "后门"
ws.Cells(n, 1).Resize(UBound(brr, 1), UBound(brr, 2)).Value = brr
n = n + 11
Next i
Set ws = Nothing
End Sub
Private Sub Swap(ByRef a As Variant, ByRef b As Variant)
Dim temp As Variant
temp = a: a = b: b = temp
End Sub
Function ExtractNumbers(ByVal inputString As String) As String
Dim outputString As String, i As Long, lenStr As Long
lenStr = Len(inputString)
For i = 1 To lenStr
If IsNumeric(Mid(inputString, i, 1)) Then outputString = outputString & Mid(inputString, i, 1)
Next i
ExtractNumbers = outputString
End Function
Function ShuffleArray2D(ByRef arr As Variant) As Variant
Dim i As Long, j As Long, RandomIndex As Long, temp As Variant
For i = UBound(arr, 1) To 1 Step -1
RandomIndex = Int((i - 1) * Rnd) + 1
For j = 1 To UBound(arr, 2)
temp = arr(i, j)
arr(i, j) = arr(RandomIndex, j)
arr(RandomIndex, j) = temp
Next j
Next i
ShuffleArray2D = arr
End Function
Function FilterArray2D(ByRef arr As Variant, ByVal key As Variant, ByVal FilterCol As Integer) As Variant
Dim brr As Variant, k As Long, i As Long, j As Long
For i = LBound(arr, 1) To UBound(arr, 1)
If key = arr(i, FilterCol) Then k = k + 1
Next i
ReDim brr(LBound(arr, 1) To k, LBound(arr, 2) To UBound(arr, 2))
k = 1
For i = LBound(arr, 1) To UBound(arr, 1)
If key = arr(i, FilterCol) Then
For j = LBound(arr, 2) To UBound(arr, 2)
brr(k, j) = arr(i, j)
Next j
k = k + 1
End If
Next i
FilterArray2D = brr
End Function
Function keys(ByRef arr As Variant, ByVal FilterCol As Integer) As Variant
Dim i As Long, dic As Object: Set dic = CreateObject("Scripting.Dictionary")
For i = LBound(arr, 1) To UBound(arr, 1)
If Not dic.exists(arr(i, FilterCol)) Then dic.Add arr(i, FilterCol), Empty
Next
keys = dic.keys:Set dic = Nothing
End Function
|
|
楼主: cai2532
沪公网安备 31011702000001号 沪ICP备11019229号-2
发表于 2024-6-21 15:16
楼主
