ymes

範例如下：

========================
呃……改成這樣後，變成沒有名單，無法執行，之前是我眼花嗎……

======================================
有時會出現偵錯，有時會出現沒有名單，無法執行

Andy2483

回復 11# ymes


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

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

ymes

回復 12# Andy2483


不好意思，造成您困擾了，

學校報名系統跑出來資訊是一年一班、一年二班……

一、剛試了一下，改成以上樣式，60M會出現錯誤訊息，但100M是會跑出正確結果

下載 (32.49 KB)

2023-2-10 08:39

二、原表格標題為女子100M，但改成100M女生後，會出現下圖錯誤(是我太吹毛求疵，但想說為符合競賽項目…)

下載 (54.46 KB)

2023-2-10 08:41

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

複製代碼

ymes

回復 14# Andy2483

感謝您幫忙不斷改進，讓表單能朝自己所期望的目標邁進，能再問一下嗎？

下圖中G3儲存格中先行設定：G3=IF(F3<>0,RANK(F3,$F$3:$F$10,1),"")，在分組後希望G14能自動生成為：G14=IF(F14<>0,RANK(F14,$F$14:$F$21,1),"")

希望能再次幫忙，感謝！

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

准提部林

公式+排序+vba//
Xl0000208-1.rar (35.24 KB)

下載次數: 5

2023-2-10 15:53

若未出結果..再試幾次..若都試不出來, 可能資料結構無法做出分組(同一班不能同道, 是道關卡)~~

__更正:最後一組可能未滿人數, 道次會有誤差, 以空格填入
      最後一組人數不足時, 不會由1~?順序排列, 會有間隔

Andy2483

回復 17# 准提部林


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

准提部林

改下//最後一組無間隔//
Xl0000208-2.rar (39.29 KB)

下載次數: 3

2023-2-10 18:42

ymes

回復 16# Andy2483


不好意思，因為真的不懂vba，所以可能動了些自以為是的地方，可能讓您困擾，說聲抱歉了！

雖然  准提部林大大說用公式+vba可解決以下困擾，但還想說問問看：

一、原本A:C欄分別為班級、姓名、項目，想改成取A:D欄，分別為項目、班級、姓名、學號，要怎麼改動呢？

二、可以做個分組鈕，讓一鍵完成隨機分組嗎？這樣就不用到各分頁一一去按分組鈕了

三、各單項競賽L:N欄原本有驗證資訊，可以像 准提部林大大般，加上分配的組別及道次嗎？

再次衷心感謝您的幫忙！