1234
返回列表 上一主題 發帖

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

Andy2483
　暱稱: 厚臉皮的學生

碩士班Rank: 5Rank: 5

帖子
1567 
主題
40 
精華
0 
積分
1591 
點名
0  
作業系統
Windows 7 
軟體版本
Excel 2010 & 2016 
閱讀權限
100 
性別
男 
來自
台灣 
註冊時間
2020-7-15 
最後登錄
2026-2-2 
25# 跳轉到 »
發表於 2023-2-11 10:22 | 只看該作者
回復 19# 准提部林


    謝謝前輩
以下心得註解請前輩再指導,謝謝

Sub 重置資料()
Dim R&
'↑宣告變數!R是長整數變數
R = [m65536].End(3).Row
'↑令R這長整數變數是 M欄最後一個有內容儲存格列號
If R < 2 Then Exit Sub
'↑令如果R變數 < 2 !就結束程式執行
Application.ScreenUpdating = False
'↑令螢幕暫不隨程式執行作變化
With Range("m2:p" & R)
'↑以下是關於[M2]到 P欄第 R變數列,這範圍儲存格的程序
     .Columns(3) = "=IF(M2="""",999,COUNTIF(M$1:M2,M2))"
     '↑令這範圍內相對欄位的第3欄(O欄)值是 (公式)字串
     '公式:如果M2是空字元的條件成立,就顯示 999,
     '否則就計算M欄前幾列裡 有幾個(當列M欄相同字串)
     .Sort Key1:=.Item(3), Order1:=xlAscending, Header:=xlNo
     '↑令資料以O欄做沒有標題列的順排序
     .Columns(3) = ""
     '↑令這範圍內相對欄位的第3欄(O欄)值是 空字元
     .Columns(4) = "=INT((ROW(A1)-1)/K$3)+1"
     '↑令這範圍內相對欄位的第4欄(P欄)值是 (公式)字串,
     '公式:前一列號減1後除以[K3]儲存格值,再去除小數轉化為整數,最後+1
     '用前一列號除的意義是:不會整除,就不必擔心整除不加 1的問題,謝謝前輩
     .Columns(4) = .Columns(4).Value
     '↑令這範圍內相對欄位的第4欄(P欄)值是 自身公式計算值
End With
End Sub
用行動裝置瀏覽論壇學習很方便,謝謝論壇經營團隊
請大家一起上論壇來交流

TOP

准提部林

帖子
2848 
主題
10 
精華
0 
積分
2903 
點名
0  
作業系統
〔略〕 
軟體版本
〔略〕 
閱讀權限
100 
性別
男 
來自
〔略〕 
註冊時間
2013-5-13 
最後登錄
2026-7-25 
24#
發表於 2023-2-11 10:01 | 只看該作者
回復 20# ymes


一、原本A:C欄分別為班級、姓名、項目，想改成取A:D欄，分別為項目、班級、姓名、學號，要怎麼改動呢？
__看來這還是草槁版本, 一般學號會放在姓名前面吧!  
__項目名稱的"男生/女生"固定放後面? 且只有賽跑項目?
__最好給完整"定案版", 論壇給的是解決方案而不是代工, 自己要能自行更改程式的

二、可以做個分組鈕，讓一鍵完成隨機分組嗎？這樣就不用到各分頁一一去按分組鈕了
__一次各分頁自動完成是可以, 但必須自己要先建立所需分表, 並輸入必要的參數
__各分表都要再次人工檢查驗證正確性, 那麼個別單頁執行也沒啥差別(反正單頁執行並不太花時間)

三、各單項競賽L:N欄原本有驗證資訊，可以像 准提部林大大般，加上分配的組別及道次嗎？
__L:N欄"原本"有驗證資訊---附件沒有看到那"原本"資料??? 那來的?

公式+VBA+工作表基本操作.....有時更有利於表格的製作及處理, 不能偏廢!!!

TOP

Andy2483
　暱稱: 厚臉皮的學生

碩士班Rank: 5Rank: 5

帖子
1567 
主題
40 
精華
0 
積分
1591 
點名
0  
作業系統
Windows 7 
軟體版本
Excel 2010 & 2016 
閱讀權限
100 
性別
男 
來自
台灣 
註冊時間
2020-7-15 
最後登錄
2026-2-2 
23#
發表於 2023-2-11 09:22 | 只看該作者
回復 21# ymes


    謝謝 准提部林前輩指導,謝謝前輩一起學習
以下是片段學習心得註解,先提供給前輩參考
此段心得重點在於:用同一陣列濾出符合條件的資料,精確的將資料放入目標儲存格中

Option Explicit
Sub A_載入資料()
Dim Arr, TC$, T$, i&, N&
'↑宣告變數!Arr是通用型變數,(TC,T)是字串變數,(i,N)是長整數變數
Call C_清除
'↑執行(C_清除)副程式
TC = [k2]
'↑令TC這字串變數是 [k2]儲存格值
If TC = "" Then MsgBox "＊未輸入項目名稱！　": Exit Sub
'↑如果TC變數是 空字元!就跳出提視窗~~,按確認後即結束程式執行
Application.ScreenUpdating = False
'↑令螢幕暫不隨程式執行作變化
Arr = Range([報名表!c1], [報名表!a65536].End(3))
'↑令Arr這通用型變數是二維陣列,以"報名表"工作表[C1]到A欄最後一個有內容儲存格,
'這範圍儲存格值倒入陣列中
For i = 2 To UBound(Arr)
'↑設順迴圈!i從2到Arr陣列縱向最大索引列號
    If Arr(i, 3) = TC Then
    '↑如果i迴圈列第3欄Arr陣列值是 TC變數??
       N = N + 1
       '↑令這N長整數變數累加 1
       Arr(N, 1) = Arr(i, 1)
       '↑令N變數列第1欄Arr陣列值是 i迴圈列第1欄Arr陣列值
       Arr(N, 2) = Arr(i, 2)
       '↑令N變數列第2欄Arr陣列值是 i迴圈列第2欄Arr陣列值
    End If
Next i
If N = 0 Then MsgBox "＊沒有符合項目資料！　": Exit Sub
'↑如果N變數是 0!就跳出提示窗~~,按確認後即結束程式執行
[m2].Resize(N, 4).Value = Arr
'↑令[m2]擴展向下N變數列,向右4欄的範圍儲存格值以Arr陣列值倒入
Call 重置資料
'↑執行(重置資料)副程式
End Sub
用行動裝置瀏覽論壇學習很方便,謝謝論壇經營團隊
請大家一起上論壇來交流

TOP

Andy2483
　暱稱: 厚臉皮的學生

碩士班Rank: 5Rank: 5

帖子
1567 
主題
40 
精華
0 
積分
1591 
點名
0  
作業系統
Windows 7 
軟體版本
Excel 2010 & 2016 
閱讀權限
100 
性別
男 
來自
台灣 
註冊時間
2020-7-15 
最後登錄
2026-2-2 
22#
發表於 2023-2-11 08:30 | 只看該作者
本帖最後由 Andy2483 於 2023-2-11 08:38 編輯

回復 21# ymes


    謝謝前輩繼續一起學習

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

謝謝論壇,謝謝各位前輩
用行動裝置瀏覽論壇學習很方便,謝謝論壇經營團隊
請大家一起上論壇來交流

TOP

ymes

帖子
62 
主題
9 
精華
0 
積分
252 
點名
260  
作業系統
winxp 
軟體版本
office2003 
閱讀權限
20 
性別
男 
註冊時間
2010-10-11 
最後登錄
2026-10-2 

2025年全勤獎章2024年全勤獎章2023年全勤獎章2022虎年全勤獎章2021牛年全勤獎章2020鼠年全勤獎章2019 豬年全勤獎章2018 狗年全勤獎章2017 雞年全勤獎章2016猴年全勤獎章2015羊年全勤獎章2014馬年全勤獎章2013蛇年全勤獎章2011兔年全勤獎章
21#
發表於 2023-2-10 23:08 | 只看該作者
回復 19# 准提部林


    謝謝您提供另一個想法，vba真的不會，但看到vba這麼方便，都懶得寫公式了……
~昨日種種，譬如昨日死~
~今日種種，譬如今日生~

TOP

ymes

帖子
62 
主題
9 
精華
0 
積分
252 
點名
260  
作業系統
winxp 
軟體版本
office2003 
閱讀權限
20 
性別
男 
註冊時間
2010-10-11 
最後登錄
2026-10-2 

2025年全勤獎章2024年全勤獎章2023年全勤獎章2022虎年全勤獎章2021牛年全勤獎章2020鼠年全勤獎章2019 豬年全勤獎章2018 狗年全勤獎章2017 雞年全勤獎章2016猴年全勤獎章2015羊年全勤獎章2014馬年全勤獎章2013蛇年全勤獎章2011兔年全勤獎章
20#
發表於 2023-2-10 22:48 | 只看該作者
回復 16# Andy2483


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

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

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

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

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

再次衷心感謝您的幫忙！

運動會分組表20230210-1.zip (58.64 KB)

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

TOP

准提部林

帖子
2848 
主題
10 
精華
0 
積分
2903 
點名
0  
作業系統
〔略〕 
軟體版本
〔略〕 
閱讀權限
100 
性別
男 
來自
〔略〕 
註冊時間
2013-5-13 
最後登錄
2026-7-25 
19#
發表於 2023-2-10 18:43 | 只看該作者
改下//最後一組無間隔//
Xl0000208-2.rar (39.29 KB)

TOP

Andy2483
　暱稱: 厚臉皮的學生

碩士班Rank: 5Rank: 5

帖子
1567 
主題
40 
精華
0 
積分
1591 
點名
0  
作業系統
Windows 7 
軟體版本
Excel 2010 & 2016 
閱讀權限
100 
性別
男 
來自
台灣 
註冊時間
2020-7-15 
最後登錄
2026-2-2 
18#
發表於 2023-2-10 15:59 | 只看該作者
回復 17# 准提部林


    謝謝前輩指導,後學研究一下
用行動裝置瀏覽論壇學習很方便,謝謝論壇經營團隊
請大家一起上論壇來交流

TOP

准提部林

帖子
2848 
主題
10 
精華
0 
積分
2903 
點名
0  
作業系統
〔略〕 
軟體版本
〔略〕 
閱讀權限
100 
性別
男 
來自
〔略〕 
註冊時間
2013-5-13 
最後登錄
2026-7-25 
17#
發表於 2023-2-10 15:30 | 只看該作者
本帖最後由 准提部林 於 2023-2-10 15:56 編輯

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

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

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

TOP

Andy2483
　暱稱: 厚臉皮的學生

碩士班Rank: 5Rank: 5

帖子
1567 
主題
40 
精華
0 
積分
1591 
點名
0  
作業系統
Windows 7 
軟體版本
Excel 2010 & 2016 
閱讀權限
100 
性別
男 
來自
台灣 
註冊時間
2020-7-15 
最後登錄
2026-2-2 
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
用行動裝置瀏覽論壇學習很方便,謝謝論壇經營團隊
請大家一起上論壇來交流

TOP

        靜思自在 : 看別人不順眼，是自己修養不夠。
1234
返回列表 上一主題