返回列表 上一主題 發帖

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

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

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

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

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

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

麻煩請大家能予以協助,感謝!

運動會分組表.zip (10.5 KB)

~昨日種種,譬如昨日死~
~今日種種,譬如今日生~

回復 1# ymes


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

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

執行前:
2023-02-07_085001.JPG
2023-2-7 09:25


執行1:
2023-02-07_085007.JPG
2023-2-7 09:26


執行2:
2023-02-07_085020.JPG
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
看得懂是應該的,懂得應用才像學生,臉皮厚點學會更謹慎積極

TOP

回復 2# Andy2483


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

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

一、若跑道為八個跑道,要如何修改呢?

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

可以的話,再勞煩幫忙想一下,感謝!

運動會分組表二.zip (16.18 KB)

~昨日種種,譬如昨日死~
~今日種種,譬如今日生~

TOP

本帖最後由 Andy2483 於 2023-2-8 09:52 編輯

回復 3# ymes


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

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

執行前:
2023-02-08_095054.JPG
2023-2-8 09:51


執行結果:
2023-02-08_093004.JPG
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
看得懂是應該的,懂得應用才像學生,臉皮厚點學會更謹慎積極

TOP

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

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

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

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

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

~昨日種種,譬如昨日死~
~今日種種,譬如今日生~

TOP

本帖最後由 Andy2483 於 2023-2-8 16:45 編輯

回復 5# ymes


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

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

PS:各年級建議分開儲存
看得懂是應該的,懂得應用才像學生,臉皮厚點學會更謹慎積極

TOP

本帖最後由 ymes 於 2023-2-8 22:15 編輯

回復 6# Andy2483


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

請問:

如果要增設項目,要在哪裡改參數呀?

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

=============================================
試了一下,原來增加新的分頁,就可以,我再試試,非常感謝您!
~昨日種種,譬如昨日死~
~今日種種,譬如今日生~

TOP

本帖最後由 Andy2483 於 2023-2-9 08:56 編輯

回復 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
看得懂是應該的,懂得應用才像學生,臉皮厚點學會更謹慎積極

TOP

回復 8# Andy2483

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

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

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

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

最後,再次感謝您的幫忙,讓在下能較順利完成檢錄工作{:3_59:} {:3_59:} {:3_59:}
~昨日種種,譬如昨日死~
~今日種種,譬如今日生~

TOP

回復 9# ymes


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

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

二、分組抬頭女生60M想改成60M女生,卻出現錯誤,偵錯時這段話變成黃色底色:Cells(i, 2).Resize(1, 2).ClearContents,應如何修正呢?
請前輩上傳此產生錯誤的範例
看得懂是應該的,懂得應用才像學生,臉皮厚點學會更謹慎積極

TOP

        靜思自在 : 對父母要知恩,感恩、報恩。
返回列表 上一主題