Option Explicit
Sub TEST_1()
Dim Drr, Brr, Crr, Y, 亂數&, 人數&, 道數&, 組數&, 執行數&, 跑道數&, i&
Dim 項目$, Arr(1 To 1000, 1 To 3), n&, m&
項目 = Split(ActiveSheet.Name, "(")(0)
跑道數 = [A3].End(xlDown).Row - 2
Drr = Range([報名表!C2], [報名表!A65536].End(3))
For i = 1 To UBound(Drr)
If Drr(i, 3) Like 項目 & "*" Then
n = n + 1
Arr(n, 1) = Drr(i, 1): Arr(n, 2) = Drr(i, 2): Arr(n, 3) = Drr(i, 3)
End If
If InStr(Cells(i, 1), 項目) Then Cells(i, 2).Resize(1, 2).ClearContents: m = m + 1
Next
If n = 0 Or m < n Then MsgBox "無法執行": Exit Sub
[L:N].ClearContents: [L1].Resize(n, 3) = Arr
人數 = n: ReDim Brr(跑道數 - 1, 1)
Head:
Set Y = CreateObject("Scripting.Dictionary")
Do While 執行數 < 人數
Randomize: 亂數 = Rnd() * 10000 Mod 人數 + 1
If Y.Exists(亂數) = Empty Then
執行數 = 執行數 + 1
Y(亂數) = ""
道數 = 執行數 Mod 跑道數
Y(Arr(亂數, 1) & "|" & 道數) = ""
組數 = IIf(道數, 執行數 \ 跑道數 + 1, 執行數 \ 跑道數)
Y(Arr(亂數, 1) & "/" & 組數) = ""
Crr = Y(組數 & "/組")
If Not IsArray(Crr) Then
Crr = Brr
End If
道數 = IIf(道數, 道數, 跑道數)
Crr(道數 - 1, 0) = Arr(亂數, 1): Crr(道數 - 1, 1) = Arr(亂數, 2)
Y(組數 & "/組") = Crr
End If
If (Y.Count - 組數) Mod 執行數 Then
組數 = 0
執行數 = 0
GoTo Head
End If
Loop
For i = 1 To 組數
[B3].Item((i - 1) * (跑道數 + 3) + 1, 1).Resize(跑道數, 2) = Y(i & "/組")
Next
End Sub
Sub 清除()
Dim 項目$, i&
項目 = Split(ActiveSheet.Name, "(")(0)
For i = 1 To [報名表!A65536].End(3)
If InStr(Cells(i, 1), 項目) Then Cells(i, 2).Resize(1, 2).ClearContents
Next
[L:N].ClearContents
End Sub作者: ymes 時間: 2023-2-8 15:04
