[已解决]求助田径比赛运动员分组分道(编排程序)

ycfxlm

在Excel工作表中，比如现有参加初中男子100米运动员18人，女子100米运动员13人（见附件）。
编排方法：
1.先根据运动员的参赛人数和提供的跑道数，确定组数（因为各学校的跑道条数不一样）；
2.同一单位的不能分在一组（除非参赛人数少，没有办法避开），各组中的人数应尽量相等；
3.运动员在组内的顺序随机产生。确定道次号时，若该组运动员刚好是跑道数（8条），就从1道开始排；若不足跑道数，不排的道次号顺序依次为1、8、2、7；若跑道数为6条，不排道次号顺序依次为1、6、2。
4.最后根据各项目生成附件中的样式。若没有办法各项目全部编排出来的话，也可以各项目分开编排，每项目参赛人数可控制在50人范围。
请各位大侠们给予帮助编一个VBA程序为谢。

最佳答案

月排行榜 / 总排行榜

grf1973

2016-2-4 14:01

你的算法不错，按你思路弄了一个。

1. Sub grf()
   
2.     pds = Sheet2.[I1]        '跑道数
   
3.     With Sheet1
   
4.         arr = .Range("a1:f" & .[a65536].End(3).Row)
   
5.         org = arr
   
6.         Set d1 = CreateObject("scripting.dictionary")
   
7.         Set d2 = CreateObject("scripting.dictionary")
   
8.         
   
9.         For i = 2 To UBound(arr)       '参加各项目的人数，行号
   
10.             d1(arr(i, 4)) = d1(arr(i, 4)) & "," & i
    
11.         Next
    
12.    
    
13.         For Each xm In d1.keys      '对于每个项目
    
14.             xrr = Split(d1(xm), ",")       '各项目的行号
    
15.             rs = UBound(xrr)                                         '第1步：统计项目人数
    
16.             zs = Int((rs - 0.001) / pds) + 1                         ' 第2步：确定组次
    
17.             For k = 1 To UBound(xrr)                                 '第3步：对项目进行分组
    
18.                 i = xrr(k)
    
19.                 n = n + 1
    
20.                 If n > zs Then n = 1
    
21.                 arr(i, 5) = xm & n
    
22.                 arr(i, 6) = Rnd        '随机数辅助列，用于乱序
    
23.             Next
    
24.         Next
    
25.         .Range("a1:f" & .[a65536].End(3).Row) = arr
    
26.         .Range("a2:f" & .[a65536].End(3).Row).Sort key1:=.[e2], key2:=.[f2]      '第4步：在各组内对运动员进行顺机排序
    
27.         arr = .Range("a1:f" & .[a65536].End(3).Row)
    
28.         .Range("a1:f" & .[a65536].End(3).Row) = org     '恢复原序
    
29.         For i = 2 To UBound(arr)
    
30.             d2(arr(i, 5)) = d2(arr(i, 5)) & "," & i       '每组人所在行
    
31.         Next
    
32.     End With
    
33.         
    
34.     With Sheet2                                                                   '第5步：确定道次
    
35.         .[a2].Resize(10000, 6).Clear
    
36.         For Each zu In d2.keys       '对于每个组
    
37.             xrr = Split(d2(zu), ",")
    
38.             bzrs = UBound(xrr)      '本组人数
    
39.             ReDim brr(1 To pds, 1 To 6)
    
40.             qs = Int((pds - bzrs + 1) / 2) + 1      '起始跑道
    
41.             n = 0
    
42.             For k = 1 To pds
    
43.                 brr(k, 1) = Right(zu, 1)
    
44.                 brr(k, 2) = k
    
45.                 If k >= qs Then
    
46.                     n = n + 1
    
47.                     If n <= bzrs Then
    
48.                         i = xrr(n)
    
49.                         For j = 1 To 4: brr(k, j + 2) = arr(i, j): Next
    
50.                     End If
    
51.                 End If
    
52.             Next
    
53.              r = .[a65536].End(3).Row + 1
    
54.             .Cells(r, 1).Resize(pds, 6) = brr     '显示本项目安排结果
    
55.         Next
    
56. 
    
57.         r = .[a65536].End(3).Row + 1     '加空格
    
58.         For i = r To 3 Step -1
    
59.             If .Cells(i, 1) <> .Cells(i - 1, 1) Then .Rows(i).Insert
    
60.         Next
    
61.     End With
    
62. End Sub

复制代码

跳转到最佳答案楼层

c888

学习

ycfxlm

求助大家分享下吧

grf1973

1. Sub fz()
   
2.     Dim Flag As Boolean
   
3.     arr = Sheet1.[a1].CurrentRegion
   
4.     Set d = CreateObject("scripting.dictionary")
   
5.     Set d1 = CreateObject("scripting.dictionary")
   
6.     For i = 2 To UBound(arr)       '参加各项目的人数，行号
   
7.         d(arr(i, 4)) = d(arr(i, 4)) + 1
   
8.         d1(arr(i, 4)) = d1(arr(i, 4)) & "," & i
   
9.     Next
   
10.     With Sheet2
    
11.     'pds = 8  '跑道数
    
12.         pds = .[I1]
    
13.         .[a2].Resize(10000, 6).Clear
    
14.         For Each xm In d.keys
    
15.             rs = d(xm)     '人数
    
16.             xrr = Split(d1(xm), ",")       '各项目的行号
    
17.             ReDim yrr(1 To UBound(xrr) + 1)   '随机编排后各项目的行号
    
18.             n = rs
    
19.             For p = 1 To rs
    
20.                 k = Int(Rnd * n + 1)    '随机编排
    
21.                 yrr(p) = xrr(k)
    
22.                 xrr(k) = xrr(n)
    
23.                 n = n - 1
    
24.             Next
    
25.             zs = Int((rs - 0.001) / pds) + 1     '组数
    
26.             mzrs = Int(rs / zs)       '每组人数
    
27.             ReDim brr(1 To zs * pds + zs, 1 To 6)
    
28.             zc = 0: n = 0
    
29.             For k = 1 To UBound(brr)
    
30.                 Flag = False       '当前跑道是否安排队员（默认为不安排）
    
31.                 If n = rs Then Exit For
    
32.                 If k Mod pds = 1 Then zc = zc + 1 '组次
    
33.                 pd = IIf(k Mod pds = 0, pds, k Mod pds)  '跑道
    
34.                 brr(k, 1) = zc: brr(k, 2) = pd
    
35.                 If mzrs = pds Then Flag = True  '每组人数=跑道数，全部安排
    
36.                 If (pd >= 2 And pd <= pds - 1) Then Flag = True    '第2到倒数第2跑道全部安排
    
37.                 If (pds = mzrs + 1 And pd = pds) Then Flag = True     '每组安排pds-1人，最后一条跑道安排
    
38.                 If rs - n <= 2 Then Flag = True    '最后未安排的2人，安排
    
39.                 If Flag = True Then       '安排队员进跑道
    
40.                      n = n + 1
    
41.                      i = yrr(n)
    
42.                      For j = 1 To 4: brr(k, j + 2) = arr(i, j): Next
    
43.                 End If
    
44.             Next
    
45.             r = .[a65536].End(3).Row + 1
    
46.             .Cells(r, 1).Resize(k, 6) = brr     '显示本项目安排结果
    
47.         Next
    
48.    
    
49.         r = .[a65536].End(3).Row + 1     '加空格
    
50.         For i = r To 3 Step -1
    
51.             If .Cells(i, 1) <> .Cells(i - 1, 1) Then .Rows(i).Insert
    
52.         Next
    
53.     End With
    
54. End Sub
    

复制代码

grf1973

关键是如何根据跑道数分组的问题。
组数=人数/跑道数，取整加1。。。。这没问题
每组人数=人数/组数，取整。。。。。有点问题。如何优化很费脑子，留待高手吧。

ycfxlm

非常感谢grf1973在百忙之中抽出宝贵的时间来帮我解决问题，在此对你的辛勤负出表示衷心的谢意。
我试了下，如果刚好被跑道数整除的话就没有问题，不被整除的话就要多一组样。看能不能用余数函数解决问题。还有一个就是组内出现了同一单位的运动员，看能不能解决同一单位运动员不在同一组内，除非没有办法才在同一组内，如有某单位有三人参加，而只有二个组比赛就会出现同一单位在一组内参赛。
再次感谢您！谢谢！

ycfxlm

因为我对ＶＢ不是很懂，谢谢大家了。

ycfxlm

grf1973讲师：
    我们是这样编排的，第1步统计项目人数；第2步根据道次确定组次；第3步对项目进行分组；第4步对运动员进行分道。
比如第1步统计出初男100米有16人参赛（跑道数是6条）
第2步：确定组次16/6＝2余4，则组次为2+1＝3组（若没有余数就为商）
第3步：分组方法是从第1名运动员到16名运动员依次输入1，2，3，1，2，3，1，2，3，1，2，3，1，2，3，1。最后按组次排序，就分成了111111,22222,33333。
第4步：在各组内对运动员进行顺机排序，确定道次，若组内道次未排满，就按第1道，第6道，第2道的顺序不排，若是8条道，就按1、8、2、7道不排。

这是一个项目的编排方法，最后排所有项目同时编排出来就OK了，能否根据这样的方式编排一个程序，谢谢！

ycfxlm

请各位大师们给予帮助为谢！！！

grf1973

你的算法不错，按你思路弄了一个。

1. Sub grf()
   
2.     pds = Sheet2.[I1]        '跑道数
   
3.     With Sheet1
   
4.         arr = .Range("a1:f" & .[a65536].End(3).Row)
   
5.         org = arr
   
6.         Set d1 = CreateObject("scripting.dictionary")
   
7.         Set d2 = CreateObject("scripting.dictionary")
   
8.         
   
9.         For i = 2 To UBound(arr)       '参加各项目的人数，行号
   
10.             d1(arr(i, 4)) = d1(arr(i, 4)) & "," & i
    
11.         Next
    
12.    
    
13.         For Each xm In d1.keys      '对于每个项目
    
14.             xrr = Split(d1(xm), ",")       '各项目的行号
    
15.             rs = UBound(xrr)                                         '第1步：统计项目人数
    
16.             zs = Int((rs - 0.001) / pds) + 1                         ' 第2步：确定组次
    
17.             For k = 1 To UBound(xrr)                                 '第3步：对项目进行分组
    
18.                 i = xrr(k)
    
19.                 n = n + 1
    
20.                 If n > zs Then n = 1
    
21.                 arr(i, 5) = xm & n
    
22.                 arr(i, 6) = Rnd        '随机数辅助列，用于乱序
    
23.             Next
    
24.         Next
    
25.         .Range("a1:f" & .[a65536].End(3).Row) = arr
    
26.         .Range("a2:f" & .[a65536].End(3).Row).Sort key1:=.[e2], key2:=.[f2]      '第4步：在各组内对运动员进行顺机排序
    
27.         arr = .Range("a1:f" & .[a65536].End(3).Row)
    
28.         .Range("a1:f" & .[a65536].End(3).Row) = org     '恢复原序
    
29.         For i = 2 To UBound(arr)
    
30.             d2(arr(i, 5)) = d2(arr(i, 5)) & "," & i       '每组人所在行
    
31.         Next
    
32.     End With
    
33.         
    
34.     With Sheet2                                                                   '第5步：确定道次
    
35.         .[a2].Resize(10000, 6).Clear
    
36.         For Each zu In d2.keys       '对于每个组
    
37.             xrr = Split(d2(zu), ",")
    
38.             bzrs = UBound(xrr)      '本组人数
    
39.             ReDim brr(1 To pds, 1 To 6)
    
40.             qs = Int((pds - bzrs + 1) / 2) + 1      '起始跑道
    
41.             n = 0
    
42.             For k = 1 To pds
    
43.                 brr(k, 1) = Right(zu, 1)
    
44.                 brr(k, 2) = k
    
45.                 If k >= qs Then
    
46.                     n = n + 1
    
47.                     If n <= bzrs Then
    
48.                         i = xrr(n)
    
49.                         For j = 1 To 4: brr(k, j + 2) = arr(i, j): Next
    
50.                     End If
    
51.                 End If
    
52.             Next
    
53.              r = .[a65536].End(3).Row + 1
    
54.             .Cells(r, 1).Resize(pds, 6) = brr     '显示本项目安排结果
    
55.         Next
    
56. 
    
57.         r = .[a65536].End(3).Row + 1     '加空格
    
58.         For i = r To 3 Step -1
    
59.             If .Cells(i, 1) <> .Cells(i - 1, 1) Then .Rows(i).Insert
    
60.         Next
    
61.     End With
    
62. End Sub

复制代码