Andy2483

回復 1# ymes


    謝謝前輩發表此主題與範例
後學學習後建議方案如下,請前輩試試看

運動會分組表_20230207.zip (22.68 KB)

下載次數: 7

2023-2-7 09:24

執行前:

下載 (173.96 KB)

2023-2-7 09:25

執行1:

下載 (191.1 KB)

2023-2-7 09:26

執行2:

下載 (191.04 KB)

2023-2-7 09:26

Option Explicit
Sub TEST_1()
Dim Arr, Brr, Crr, Y, 亂數&, 人數&, 道數&, 組數&, 項數&, 跑道數&, i&
Arr = Range([報名表!B2], [報名表!A65536].End(3))
人數 = UBound(Arr): 跑道數 = 6: 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
With Sheets("分組表")
   For i = 1 To 組數
      .[B3].Item((i - 1) * 9 + 1, 1).Resize(跑道數, 2) = Y(i & "/組")
   Next
End With
Set Arr = Nothing
Set Brr = Nothing
Set Crr = Nothing
Set Y = Nothing
End Sub

Andy2483

回復 3# ymes


    謝謝前輩回復
修改方案如下,請前輩試試看

運動會分組表_20230208.zip (40.87 KB)

下載次數: 2

2023-2-8 09:43

執行前:

下載 (131.69 KB)

2023-2-8 09:51

執行結果:

下載 (180.97 KB)

2023-2-8 09:44

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

Andy2483

回復 5# ymes


    二年級項目每班參加人數 4 人 !可以放寬同一組同一班兩人參賽嗎?

一年級範例再試試看:
20230208_運動會分組表_一年級.zip (54.69 KB)

下載次數: 4

2023-2-8 16:41

PS:各年級建議分開儲存

Andy2483

回復 7# ymes


    謝謝前輩再回復
1.後學複習了一下,做了註解,請前輩參考
2.如果跑道數,每班人數,同班不同道這些條件導致隨機組合無解!! 該如何設計才能判定無解?? 並跳出 "無解" 提視窗後結束程序??
例如:每班人數4人會導致無解,請前輩們指導,謝謝

Option Explicit
Sub TEST_1()
Dim Drr, Brr, Crr, Y, 亂數&, 人數&, 道數&, 組數&, 執行數&, 跑道數&, i&
Dim 項目$, Arr(1 To 1000, 1 To 3), n&, m&
'↑宣告變數:(Drr, Brr, Crr, Y)是通用型變數,項目 是字串變數,Arr是二維陣列,
'其他是長整數變數
項目 = Split(ActiveSheet.Name, "(")(0)
'↑令 項目 這字串變數是 以"("符號 將工作表名分割成一維陣列取0索引號的字串
跑道數 = [A3].End(xlDown).Row - 2
'↑令 (跑道數) 這長整數變數是 從[A3]儲存格往下找到空格的前一格列號 - 2
Drr = Range([報名表!C2], [報名表!A65536].End(3))
'↑令 Drr這通用型變數 是二維陣列,以報名表[C2]到A欄最後一個有內容儲存格值倒入
For i = 1 To UBound(Drr)
'↑設順迴圈!從1到 Drr陣列縱向最後索引號
   If Drr(i, 3) Like 項目 & "*" Then
   '↑如果i迴圈數第3欄Drr陣列值是 (項目)變數 開頭的字串??
      n = n + 1
      '↑令n這長整數變數 累加1
      Arr(n, 1) = Drr(i, 1): Arr(n, 2) = Drr(i, 2): Arr(n, 3) = Drr(i, 3)
      '↑令n變數列第1欄Arr陣列值是 i變數列第1欄Drr陣列值,~~依此類推
   End If
   If InStr(Cells(i, 1), 項目) Then Cells(i, 2).Resize(1, 2).ClearContents: m = m + 1
   '↑如果工作表i變數列第1欄儲存格值 包含了(項目)變數字串!就清除右側兩儲存格的內容,
   '令m這長整數變數累加1
Next
If n = 0 Then
'↑如果n變數是 0?
   MsgBox "沒有名單!無法執行": Exit Sub
   '↑跳出提示窗~"沒有名單!無法執行"~,之後結束程式執行
End If
If m < n Then
'↑如果 m變數小於 n變數?
   MsgBox "組數表格不夠!無法執行": Exit Sub
   '↑跳出提示窗~"組數表格不夠!無法執行"~,之後結束程式執行
End If
[L:N].ClearContents: [L1].Resize(n, 3) = Arr
'↑令[L:N]這3欄儲存格內容清除 :令[L1]擴展向下n變數列,向右擴展3欄的範圍儲存格以Arr陣列值倒入
人數 = n: ReDim Brr(跑道數 - 1, 1)
'↑令 人數這長整數變數是 n變數值: 宣告Brr陣列大小(縱向從0到 跑道數-1,橫向從0到 1)
Head:
Set Y = CreateObject("Scripting.Dictionary")
'↑令Y是 字典
Do While 執行數 < 人數
'↑設條件迴圈:當 (執行數)變數 < (人數)變數!就繼續執行!
   Randomize: 亂數 = Rnd() * 10000 Mod 人數 + 1
   '↑令 亂數這長整數變數是 1 到 (人數)變數的Rnd()亂數值
   If Y.Exists(亂數) = Empty Then
   '↑如果產生的(亂數)變數值沒有在Y字典裡?
      執行數 = 執行數 + 1
     '↑令(執行數)這長整數變數 累加1
      Y(亂數) = ""
      '↑令(亂數)變數當key,item是空字元放入Y字典
      道數 = 執行數 Mod 跑道數
      '↑令(道數)這長整數變數是 (執行數) 除 (跑道數) 的餘數
      Y(Arr(亂數, 1) & "|" & 道數) = ""
      '↑令(亂數)變數列第1欄Arr陣列值 連接 "|" 再連接 (道數)變數的組合字串當key,item是空字元放入Y字典
      組數 = IIf(道數, 執行數 \ 跑道數 + 1, 執行數 \ 跑道數)
      '↑令(組數)這長整數變數是 以IIf()判斷的回傳值,
      '如果(道數)變數不是0,就令(組數)變數是 (執行數)變數 除 (跑道數)的商取整數後 + 1
      '如果(道數)變數是0,就令(組數)變數是 (執行數)變數 除 (跑道數)的商取整數
      Y(Arr(亂數, 1) & "/" & 組數) = ""
      '↑令(亂數)列第1欄Arr陣列值 連接 "/" 再連接 (組數)變數的組合字串當key,item是空字元放入Y字典
      Crr = Y(組數 & "/組")
      '↑令Crr這通用型變數是 以(組數)變數 連接 "/組"成的組合字串當key,查Y字典得到的item
      If Not IsArray(Crr) Then
      '↑如果Crr變數不是陣列?
         Crr = Brr
         '↑令Crr 是 Brr陣列
      End If
      道數 = IIf(道數, 道數, 跑道數)
      '↑令(道數)變數是 以IIf()判斷的回傳值,
      '如果(道數)變數不是0!就令(道數)變數是 (道數)變數
      '如果(道數)變數是0!就令(道數)變數是 (跑道數)變數
      Crr(道數 - 1, 0) = Arr(亂數, 1): Crr(道數 - 1, 1) = Arr(亂數, 2)
      '↑令(道數)變數-1索引號列第0索引號欄Crr陣列值是 (亂數)變數列第1欄Arr陣列值
      '↑令(道數)變數-1索引號列第1索引號欄Crr陣列值是 (亂數)變數列第2欄Arr陣列值
      Y(組數 & "/組") = Crr
      '↑令以(組數)變數連接 "/組" 的組合字串當key,item是 Crr陣列,放入Y字典
      '如果該key已存在Y陣列!就取代其item
   End If
   If (Y.Count - 組數) Mod 執行數 Then
   '↑如果(Y字典key數量 - (組數)變數) 除 (執行數)變數的餘數不是0?
      組數 = 0
      '↑令(組數)變數是 0
      執行數 = 0
      '↑令(執行數)變數是 0
      GoTo Head
      '↑跳到 Head標示處繼續執行
   End If
Loop
'↑跳到 Do 位置繼續執行
For i = 1 To 組數
'↑設順迴圈!i從1到 (組數)變數
   [B3].Item((i - 1) * (跑道數 + 3) + 1, 1).Resize(跑道數, 2) = Y(i & "/組")
   '↑[B3]儲存格擴展向下(跑道數)變數列,向右擴展2欄範圍儲存格以 陣列值 倒入,
   '陣列值是:以 i迴圈數 連接 "/組"的組合字串當key,查Y字典得到的item
Next
End Sub

Andy2483

回復 9# ymes


    如果……如果再發問，會不會太過份呀……
謝謝前輩繼續發問,給後學繼續學習

一、若每班可報名三人參加單項競賽，雖也會跑出正確結果，但似乎會跑較久，但仍會輸出正確結果(有時四、五秒，有時二十秒左右)
機率的問題:每班3人,不同組,不同道 的組合比較少,論壇很多厲害的前輩或許看到可以幫我們一把,提升效率,謝謝各位前輩

二、分組抬頭女生60M想改成60M女生，卻出現錯誤，偵錯時這段話變成黃色底色：Cells(i, 2).Resize(1, 2).ClearContents，應如何修正呢？
請前輩上傳此產生錯誤的範例

Andy2483

回復 11# ymes


    前輩早安
101:一年一班
102:一年二班
~
201:二年一班
202:二年二班
~
~
501:五年一班

不是這規則嗎?
現在的範例與#5樓的範例有衝突
實際的年級班級是什麼規則?

Andy2483

回復 13# ymes


    謝謝前輩繼續一起學習做研討回覆
設雙條件隨機名單不等於公平,表格陸續增減修改不會困擾,都只能選擇接受
修改需求如下,請前輩繼續測試需求,自己修改看看,謝謝

運動會分組表20230210.zip (59.71 KB)

下載次數: 4

2023-2-10 09:36

執行前:         ps:清除後的表格若是8跑道數,就算8道名單:若刪除剩6跑到,即算6跑道名單,隨意增減

下載 (79.69 KB)

2023-2-10 09:37

執行結果:

下載 (146.13 KB)

2023-2-10 09:37

1. Option Explicit
   
2. Dim 組表格 As Range, R&, C%
   
3. Sub 開始分組()
   
4. Dim Drr, Brr, Crr, Y, 亂數&, 人數&, 道數&, 組數&, 執行數&, 跑道數&, i&
   
5. Dim 項目$, Arr(1 To 1000, 1 To 3), n&, m&, 組別, xR As Range
   
6. 項目 = Split(ActiveSheet.Name, "(")(0)
   
7. 跑道數 = [A2].End(xlDown).Row - 2
   
8. Drr = Range([報名表!C2], [報名表!A65536].End(3))
   
9. For i = 1 To UBound(Drr)
   
10.    If Drr(i, 3) Like 項目 & "*" Then
    
11.       n = n + 1
    
12.       Arr(n, 1) = Drr(i, 1): Arr(n, 2) = Drr(i, 2): Arr(n, 3) = Drr(i, 3)
    
13.    End If
    
14. Next
    
15. If n = 0 Then
    
16.    MsgBox "沒有名單!無法執行": Exit Sub
    
17. End If
    
18. If 跑道數 < 1 Then
    
19.    MsgBox "跑道數不符合規則!無法執行": Exit Sub
    
20. End If
    
21. Call 清除: [L1].Resize(n, 3) = Arr
    
22. 人數 = n: ReDim Brr(跑道數 - 1, 1)
    
23. Head:
    
24. Set Y = CreateObject("Scripting.Dictionary")
    
25. Do While 執行數 < 人數
    
26.    Randomize: 亂數 = Rnd() * 10000 Mod 人數 + 1
    
27.    If Y.Exists(亂數) = Empty Then
    
28.       執行數 = 執行數 + 1
    
29.       Y(亂數) = ""
    
30.       道數 = 執行數 Mod 跑道數
    
31.       Y(Arr(亂數, 1) & "|" & 道數) = ""
    
32.       組數 = IIf(道數, 執行數 \ 跑道數 + 1, 執行數 \ 跑道數)
    
33.       Y(Arr(亂數, 1) & "/" & 組數) = ""
    
34.       Crr = Y(組數 & "/組")
    
35.       If Not IsArray(Crr) Then Crr = Brr
    
36.       道數 = IIf(道數, 道數, 跑道數)
    
37.       Crr(道數 - 1, 0) = Arr(亂數, 1): Crr(道數 - 1, 1) = Arr(亂數, 2)
    
38.       Y(組數 & "/組") = Crr
    
39.    End If
    
40.    If (Y.Count - 組數) Mod 執行數 Then 組數 = 0: 執行數 = 0: GoTo Head
    
41. Loop
    
42. For i = 1 To 組數 - 1: 組表格.Copy Cells(i * (R + 1) + 1, 1): Next
    
43. For i = 1 To 組數
    
44.    組別 = "(第" & Application.Text(i, "[DBNum1]0") & "組)"
    
45.    Set xR = [B3].Item((i - 1) * (跑道數 + 3) + 1, 1)
    
46.    xR.Resize(跑道數, 2) = Y(i & "/組")
    
47.    Set xR = xR.Item(-1, 0)
    
48.    xR.Value = Split(xR.Value, "(")(0) & 組別
    
49. Next
    
50. End Sub
    
51. Sub 清除()
    
52. Dim uR&
    
53. R = [A2].End(xlDown).Row
    
54. C = [A2].End(xlToRight).Column
    
55. uR = ActiveSheet.UsedRange.Rows.Count
    
56. [L:N].ClearContents
    
57. [A2].End(xlDown).Item(2, 1).Resize(uR - R, C).Clear
    
58. [B3].Resize(R - 2, 2).ClearContents
    
59. Set 組表格 = Range([A1], Cells(R, C))
    
60. End Sub

複製代碼

Andy2483

回復 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

Andy2483

回復 17# 准提部林


    謝謝前輩指導,後學研究一下

Andy2483

回復 21# ymes


    謝謝前輩繼續一起學習

1.後學想法不一樣:公式是VBA智慧的精華濃縮,是後學學習EXCEL的里程碑,建議莫忽視公式
2.前輩感受到VBA的好處,以後常上論壇一起學習,讓更多事可以事半功倍
3.前輩陸續增加項目與規則,想必最終版本未定案,以往為同事設計複雜點的表格都要開會討論,
討論各方提出的意見,做出最後的定案
4.後學的經驗是程式寧願寫大一點廣一點,後續做小修改,如果條件像前輩的情境一直變更,程式常常要大改或打掉重寫,
常常改條件對學習中的後學是很好的學習機會,常常變思維,磨耐心,謝謝前輩
5.如果前輩的需求是很急迫的!建議前輩先找可最終定案的團隊一起討論出最終版本,論壇裡很多厲害的前輩可以指導
6.如果需求不急!陸續再提出不同需求討論學習也是很好的方式
7.後學拋磚引玉,,可以得到前輩們的指導,最大的意義是希望更多人一起學習

謝謝論壇,謝謝各位前輩