[已解决]组别赋值生成赛程

电子表

1、赋值要求：1、决赛；2、半决赛、决赛；3、预赛、半决赛、决赛；4、预赛、复赛、半决赛、决赛；5、预赛、复赛1、复赛2、半决赛、决赛；6、预赛、复赛1、复赛2、复赛3、半决赛、决赛；当轮次为7时依次增加复赛的数量。

2、根据轮次数确定复制行次数，并在行中赋值：决赛等。

3、规则：总人数已知，录取人数按G列规则。

4、人数小于6时，录取所有，6——12录取6，12-24录取12，24-48录取24，48-96录取48，96-192录取96 赛程生成.rar (11.38 KB, 下载次数: 7)

2014-4-11 13:59 上传

点击文件名下载附件 请论坛里的高手帮助解答!万分感谢!

最佳答案

月排行榜 / 总排行榜

grf1973

2014-4-11 15:33

又重新改了下代码，录取数根据最终的6倒算。见代码。这样就不管一开始的总人数是多少了，反正第一次预赛就把人数调整为6的偶数倍了。

1. Sub tt()
   
2.     r = Sheet1.[a65536].End(3).Row
   
3.     arr = Sheet1.Range("a3:f" & r)
   
4.     lc = Application.WorksheetFunction.Sum(Sheet1.Range("d:d"))   '总轮次
   
5.     ReDim brr(1 To lc, 1 To 6)
   
6.     For i = 1 To UBound(arr)
   
7.         blc = arr(i, 4) '本轮次
   
8.         zrs = arr(i, 5)   '总人数
   
9.         If blc = 1 Then x = "决赛"    '根据本轮次赋值
   
10.         If blc = 2 Then x = "半决赛,决赛"
    
11.         If blc = 3 Then x = "预赛,半决赛,决赛"
    
12.         If blc = 4 Then x = "预赛,复赛,半决赛,决赛"
    
13.         If blc >= 5 Then
    
14.             y = ""
    
15.             For k = 1 To blc - 3
    
16.                 y = y & "," & "复赛" & k
    
17.             Next
    
18.             x = "预赛" & y & ",半决赛,决赛"
    
19.         End If
    
20.         xrr = Split(x, ",")
    
21.         For k = 1 To blc
    
22.             m = m + 1
    
23.             brr(m, 1) = m
    
24.             brr(m, 2) = arr(i, 2)
    
25.             brr(m, 3) = arr(i, 3)
    
26.             brr(m, 4) = xrr(k - 1)
    
27.             lqs = 6 * 2 ^ (blc - k - 1)   '录取数根据本轮次数倒算
    
28.             If lqs < 6 Then lqs = 6    '如果录取数小于6，则取录取数为6
    
29.             brr(m, 5) = zrs
    
30.             brr(m, 6) = lqs
    
31.             zrs = lqs   '把录取数作为下一次的总人数
    
32.         Next
    
33.     Next
    
34.     Sheet5.[h3].Resize(m, 6) = brr
    
35. End Sub
    
36. 
    

复制代码

跳转到最佳答案楼层

grf1973

1. Sub tt()
   
2.     r = Sheet1.[a65536].End(3).Row
   
3.     arr = Sheet1.Range("a3:f" & r)
   
4.     lc = Application.WorksheetFunction.Sum(Sheet1.Range("d:d"))   '总轮次
   
5.     ReDim brr(1 To lc, 1 To 6)
   
6.     For i = 1 To UBound(arr)
   
7.         blc = arr(i, 4) '本轮次
   
8.         If blc = 1 Then x = "决赛"    '根据本轮次赋值
   
9.         If blc = 2 Then x = "半决赛,决赛"
   
10.         If blc = 3 Then x = "预赛,半决赛,决赛"
    
11.         If blc = 4 Then x = "预赛,复赛,半决赛,决赛"
    
12.         If blc >= 5 Then
    
13.             y = ""
    
14.             For k = 1 To blc - 3
    
15.                 y = y & "," & "复赛" & k
    
16.             Next
    
17.             x = "预赛" & y & ",半决赛,决赛"
    
18.         End If
    
19.         xrr = Split(x, ",")
    
20.         y = arr(i, 5) & "," & arr(i, 6)
    
21.         yrr = Split(y, ",")         '把总人数和录取人数放入数组
    
22.         For k = 1 To blc
    
23.             m = m + 1
    
24.             brr(m, 1) = m
    
25.             brr(m, 2) = arr(i, 2)
    
26.             brr(m, 3) = arr(i, 3)
    
27.             brr(m, 4) = xrr(k - 1)
    
28.             brr(m, 5) = yrr(k - 1)
    
29.             brr(m, 6) = yrr(k)
    
30.         Next
    
31.     Next
    
32.     Sheet5.[h3].Resize(m, 6) = brr
    
33. End Sub
    
34. 
    

复制代码

grf1973

请看附件。结果生成在H列以方便比较。

电子表

当F栏无数据，规则写在文本框上面，如何修改!谢谢您的帮助!

grf1973

先想办法把文本的读入到F栏不就行了？

grf1973

先想办法把文本的读入到F栏不就行了？

grf1973

我看了下规则，其实就72,36,24,12,6,6不是每次除以2，其他的都可以用公式弄的。

grf1973

我根据上面除以2的思路重新写了一下，就是那个总人数为72的录取规律改成了72，36，18，9，6，6，其他都一样的。

1. Sub tt()
   
2.     r = Sheet1.[a65536].End(3).Row
   
3.     arr = Sheet1.Range("a3:f" & r)
   
4.     lc = Application.WorksheetFunction.Sum(Sheet1.Range("d:d"))   '总轮次
   
5.     ReDim brr(1 To lc, 1 To 6)
   
6.     For i = 1 To UBound(arr)
   
7.         blc = arr(i, 4) '本轮次
   
8.         zrs = arr(i, 5)   '总人数
   
9.         If blc = 1 Then x = "决赛"    '根据本轮次赋值
   
10.         If blc = 2 Then x = "半决赛,决赛"
    
11.         If blc = 3 Then x = "预赛,半决赛,决赛"
    
12.         If blc = 4 Then x = "预赛,复赛,半决赛,决赛"
    
13.         If blc >= 5 Then
    
14.             y = ""
    
15.             For k = 1 To blc - 3
    
16.                 y = y & "," & "复赛" & k
    
17.             Next
    
18.             x = "预赛" & y & ",半决赛,决赛"
    
19.         End If
    
20.         xrr = Split(x, ",")
    
21.         For k = 1 To blc
    
22.             m = m + 1
    
23.             brr(m, 1) = m
    
24.             brr(m, 2) = arr(i, 2)
    
25.             brr(m, 3) = arr(i, 3)
    
26.             brr(m, 4) = xrr(k - 1)
    
27.             lqs = Int(zrs / 2)   '录取数=总人数/2
    
28.             If lqs < 6 Then lqs = 6    '如果录取数小于6，则取录取数为6
    
29.             brr(m, 5) = zrs
    
30.             brr(m, 6) = lqs
    
31.             zrs = lqs   '把录取数作为下一次的总人数
    
32.         Next
    
33.     Next
    
34.     Sheet5.[h3].Resize(m, 6) = brr
    
35. End Sub

复制代码

grf1973

又重新改了下代码，录取数根据最终的6倒算。见代码。这样就不管一开始的总人数是多少了，反正第一次预赛就把人数调整为6的偶数倍了。

1. Sub tt()
   
2.     r = Sheet1.[a65536].End(3).Row
   
3.     arr = Sheet1.Range("a3:f" & r)
   
4.     lc = Application.WorksheetFunction.Sum(Sheet1.Range("d:d"))   '总轮次
   
5.     ReDim brr(1 To lc, 1 To 6)
   
6.     For i = 1 To UBound(arr)
   
7.         blc = arr(i, 4) '本轮次
   
8.         zrs = arr(i, 5)   '总人数
   
9.         If blc = 1 Then x = "决赛"    '根据本轮次赋值
   
10.         If blc = 2 Then x = "半决赛,决赛"
    
11.         If blc = 3 Then x = "预赛,半决赛,决赛"
    
12.         If blc = 4 Then x = "预赛,复赛,半决赛,决赛"
    
13.         If blc >= 5 Then
    
14.             y = ""
    
15.             For k = 1 To blc - 3
    
16.                 y = y & "," & "复赛" & k
    
17.             Next
    
18.             x = "预赛" & y & ",半决赛,决赛"
    
19.         End If
    
20.         xrr = Split(x, ",")
    
21.         For k = 1 To blc
    
22.             m = m + 1
    
23.             brr(m, 1) = m
    
24.             brr(m, 2) = arr(i, 2)
    
25.             brr(m, 3) = arr(i, 3)
    
26.             brr(m, 4) = xrr(k - 1)
    
27.             lqs = 6 * 2 ^ (blc - k - 1)   '录取数根据本轮次数倒算
    
28.             If lqs < 6 Then lqs = 6    '如果录取数小于6，则取录取数为6
    
29.             brr(m, 5) = zrs
    
30.             brr(m, 6) = lqs
    
31.             zrs = lqs   '把录取数作为下一次的总人数
    
32.         Next
    
33.     Next
    
34.     Sheet5.[h3].Resize(m, 6) = brr
    
35. End Sub
    
36. 
    

复制代码

电子表

谢谢您的帮助，可否设置大于24小于等于48时均录取24。小于24时则是12，6，6。谢谢!