- 帖子
- 1446
- 主題
- 40
- 精華
- 0
- 積分
- 1470
- 點名
- 0
- 作業系統
- Windows 7
- 軟體版本
- Excel 2010 & 2016
- 閱讀權限
- 50
- 性別
- 男
- 來自
- 台灣
- 註冊時間
- 2020-7-15
- 最後登錄
- 2024-10-21
|
4#
發表於 2023-2-8 09:45
| 只看該作者
本帖最後由 Andy2483 於 2023-2-8 09:52 編輯
回復 3# ymes
謝謝前輩回復
修改方案如下,請前輩試試看
 運動會分組表_20230208.zip (40.87 KB)
執行前:
執行結果:
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 |
|
