[發問] 運動會競賽道次隨機分組

ymes

在下出現一個問題，希望大家能幫;忙：

100M比賽中，一共九個班級，每班二個人參加，想隨機分成三組，每組六人，現情況是：

一、同班不能分在同一組別

二、每班的人不能分在同一道次

麻煩請大家能予以協助，感謝！

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

ymes

回復 2# Andy2483


您太客氣了，測試了一陣子，可以用，而且非常符合在下需求，但……

巨集真的不熟，日後真的要修改比較困難，借問一下：

一、若跑道為八個跑道，要如何修改呢？

二、若有其他競賽項目也要隨機分組，又要如何修改呢？

可以的話，再勞煩幫忙想一下，感謝！

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

ymes

再次感謝，但很抱歉，在下對巨集一籌莫展，讓我過份一點，再問一些問題：

一、如果要新增其他項目(如200M、800M……甚至是男生組)，要怎麼改參數呢？

二、報名表是總表，如果要改成二年級的學生檢錄表，又要怎麼改呢？

再次提問，希望能給予解答，感激不盡

Andy2483

回復 5# ymes


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

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

下載次數: 4

2023-2-8 16:41

PS:各年級建議分開儲存

ymes

回復 6# Andy2483


是我搞錯了，100M項目沒設定到，每班單項仍然是二人為限

請問：

如果要增設項目，要在哪裡改參數呀？

譬如說新增個男生1600M或女生1600M的項目，要在哪處修改呢？

=============================================
試了一下，原來增加新的分頁，就可以，我再試試，非常感謝您！

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

ymes

回復 8# Andy2483

非常感謝您旳幫忙，目前正研讀寶典，並稍微修改中，

如果……如果再發問，會不會太過份呀……

一、若每班可報名三人參加單項競賽，雖也會跑出正確結果，但似乎會跑較久，但仍會輸出正確結果(有時四、五秒，有時二十秒左右)

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

最後，再次感謝您的幫忙，讓在下能較順利完成檢錄工作{:3_59:} {:3_59:} {:3_59:}

Andy2483

回復 9# ymes


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

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

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