- 帖子
- 1527
- 主題
- 40
- 精華
- 0
- 積分
- 1551
- 點名
- 0
- 作業系統
- Windows 7
- 軟體版本
- Excel 2010 & 2016
- 閱讀權限
- 100
- 性別
- 男
- 來自
- 台灣
- 註冊時間
- 2020-7-15
- 最後登錄
- 2025-11-4
|
16#
發表於 2023-2-10 14:32
| 只看該作者
本帖最後由 Andy2483 於 2023-2-10 14:42 編輯
回復 15# ymes
謝謝前輩,後學黔驢技窮了,請前輩們指導
不知前輩改動多少程式碼?
請將下列紅字新增或取代, 或 上傳前輩最新範例
Option Explicit
Dim 組表格 As Range, R&, C%
Sub 開始分組()
Dim Drr, Brr, Crr, Y, 亂數&, 人數&, 道數&, 組數&, 執行數&, 跑道數&, i&
Dim 項目$, Arr(1 To 1000, 1 To 3), n&, 組別, xR As Range
項目 = Split(ActiveSheet.Name, "(")(0)
跑道數 = [A2].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
Next
If n = 0 Then
MsgBox "沒有名單!無法執行": Exit Sub
End If
If 跑道數 < 1 Then
MsgBox "跑道數不符合規則!無法執行": Exit Sub
End If
Call 清除: [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
道數 = IIf(道數, 道數, 跑道數)
Crr(道數 - 1, 0) = Arr(亂數, 1): Crr(道數 - 1, 1) = Arr(亂數, 2)
Y(組數 & "/組") = Crr
End If
If (Y.Count - 組數) Mod 執行數 Then 組數 = 0: 執行數 = 0: GoTo Head
Loop
'For i = 1 To 組數 - 1: 組表格.Copy Cells(i * (R + 1) + 1, 1): Next '這行點掉,新增下列紅字
Dim S$, T&
For i = 1 To 組數 - 1
組表格.Copy Cells(i * (R + 1) + 1, 1)
T = 3 + ((R + 1) * i)
S = "=IF(F" & T & "<>0,RANK(F" & T & ",$F$" & T & ":$F$" & T + 跑道數 - 1 & ",1),"""")"
Cells(i * (R + 1) + 1, 1).Item(3, 7).Resize(跑道數, 1) = S
Next
For i = 1 To 組數
組別 = "(第" & Application.Text(i, "[DBNum1]0") & "組)"
Set xR = [B3].Item((i - 1) * (跑道數 + 3) + 1, 1)
xR.Resize(跑道數, 2) = Y(i & "/組")
Set xR = xR.Item(-1, 0)
xR.Value = Split(xR.Value, "(")(0) & 組別
Next
End Sub
Sub 清除()
Dim uR&
R = [A2].End(xlDown).Row
C = [A2].End(xlToRight).Column
uR = ActiveSheet.UsedRange.Rows.Count
[L:N].ClearContents
[A2].End(xlDown).Item(2, 1).Resize(uR - R, C).Clear
[B3].Resize(R - 2, 2).ClearContents
'新增下列紅字
[F3].Resize(R - 2, 1).ClearContents
[G3].Resize(R - 2, 1) = "=IF(F3<>0,RANK(F3,$F$3:$F$" & R & ",1),"""")"
Set 組表格 = Range([A1], Cells(R, C))
End Sub |
|
發表於 2023-2-10 15:30
| 
