单循环比赛赛程安排排定

yangyangzhifeng

在论坛大概搜索了一下，好像还没有完整的讨论，算是抛砖引玉吧
单循环比赛对阵.rar (14.42 KB, 下载次数: 580)

2012-12-23 07:17 上传

点击文件名下载附件

包含两种方法

1. Sub gdlh() '固定轮换法
   
2.     Dim ar, i&, j&, x&, n&, lunci&, y&, t&
   
3.     Dim br, k
   
4.     Const duishu = 15
   
5.     If duishu Mod 2 = 0 Then
   
6.         n = duishu / 2: lunci = duishu - 1: t = duishu
   
7.     Else
   
8.         n = (duishu + 1) / 2: lunci = duishu: t = 0
   
9.     End If
   
10.     ReDim ar(1 To n, 1 To 2): ReDim br(1 To lunci, 1 To n)
    
11.     ar(1, 1) = 1
    
12.     For i = 1 To lunci
    
13.         x = x + 1: x = IIf(x > 2 * n, 2, x)
    
14.         y = x
    
15.         For j = 2 To 2 * n
    
16.             y = y + 1
    
17.             If y > 2 * n Then y = 2
    
18.             ar(r(y, n), c(y, n)) = IIf(j = 2 * n, t, j)
    
19.         Next
    
20.         For k = 1 To UBound(ar)
    
21.             br(i, k) = Format(ar(k, 1), "000") & "_" & Format(ar(k, 2), "000")
    
22.         Next
    
23.     Next
    
24.     Sheet1.Cells.ClearContents
    
25.     Sheet1.[a1].Resize(lunci, n).Columns.AutoFit
    
26.     Sheet1.[a1].Resize(lunci, n) = br
    
27. End Sub
    
28. Function r(ByVal x As Long, n&)
    
29.     x = IIf(x <= n, x, 3 * n - x + 1)
    
30.     r = 1 + ((x - 1) Mod n)
    
31. End Function
    
32. Function c(ByVal x As Long, n&)
    
33.     x = IIf(x <= n, x, 3 * n - x + 1)
    
34.     c = (x - 1) \ n + 1
    
35. End Function

复制代码

yangyangzhifeng

上面是固定轮换法，下面再提供一个贝格尔编排法

1. 
   
2. Sub berger()
   
3.     Dim ar, i&, j&, x&, n&, lunci&, jg&, y&, t&
   
4.     Dim br, k
   
5.     Const duishu = 16
   
6.     If duishu Mod 2 = 0 Then
   
7.         n = duishu / 2: lunci = duishu - 1: t = duishu
   
8.     Else
   
9.         n = (duishu + 1) / 2: lunci = duishu: t = 0
   
10.     End If
    
11.     ReDim ar(1 To n, 1 To 2): ReDim br(1 To lunci, 1 To n)
    
12.     If duishu <= 4 Then jg = 1 Else jg = n - 1
    
13.     x = 1
    
14.     For i = 1 To lunci
    
15.         y = x - 1
    
16.         For j = 1 To 2 * n - 1
    
17.             y = y + 1
    
18.             If y > 2 * n Then y = 2
    
19.             ar(r(y, n), c(y, n)) = j
    
20.             If y = 2 * n And i Mod 2 = 1 Then ar(1, 1) = ar(1, 2)
    
21.         Next
    
22.         If i Mod 2 = 1 Then ar(1, 2) = t Else ar(1, 1) = t
    
23.         For k = 1 To UBound(ar)
    
24.             br(i, k) = Format(ar(k, 1), "000") & "_" & Format(ar(k, 2), "000")
    
25.         Next
    
26.         x = x + jg: x = IIf(x >= 2 * n, x + 1, x): x = ((x - 1) Mod 2 * n) + 1
    
27.     Next
    
28.     Sheet1.Cells.ClearContents
    
29.     Sheet1.[a1].Resize(lunci, n).Columns.AutoFit
    
30.     Sheet1.[a1].Resize(lunci, n) = br
    
31. End Sub
    
32. 
    
33. Function r(ByVal x As Long, n&)
    
34.     x = IIf(x <= n, x, 3 * n - x + 1)
    
35.     r = 1 + ((x - 1) Mod n)
    
36. End Function
    
37. Function c(ByVal x As Long, n&)
    
38.     x = IIf(x <= n, x, 3 * n - x + 1)
    
39.     c = (x - 1) \ n + 1
    
40. End Function
    

复制代码

123233513

{:soso_e179:}老师厉害！~~~~~~学习了。。。

刘志文

谢谢分享,学习了

babol

正需要，感谢。只是不知道那种方法更科学？应该都差不多吧？

wwwconsumer

楼主厉害，真的高手。

ddgod

进来学习学习

ecwj

修改了一下，这下看起来顺眼不少

1. Sub berger()
   
2.     Dim ar, i&, j&, x&, n&, lunci&, jg&, y&, t&
   
3.     Dim br, k, duishu&
   
4.     duishu = InputBox("请输入参赛对数", "对数")
   
5.     If duishu Mod 2 = 0 Then
   
6.         n = duishu / 2: lunci = duishu - 1: t = duishu
   
7.     Else
   
8.         n = (duishu + 1) / 2: lunci = duishu: t = 0
   
9.     End If
   
10.     ReDim ar(1 To n, 1 To 2): ReDim br(1 To lunci, 1 To n)
    
11.     If duishu <= 4 Then jg = 1 Else jg = n - 1
    
12.     x = 1
    
13.     For i = 1 To lunci
    
14.         y = x - 1
    
15.         For j = 1 To 2 * n - 1
    
16.             y = y + 1
    
17.             If y > 2 * n Then y = 2
    
18.             ar(r(y, n), c(y, n)) = j
    
19.             If y = 2 * n And i Mod 2 = 1 Then ar(1, 1) = ar(1, 2)
    
20.         Next
    
21.         If i Mod 2 = 1 Then ar(1, 2) = t Else ar(1, 1) = t
    
22.         For k = 1 To UBound(ar)
    
23.             br(i, k) = Format(ar(k, 1), "0") & "--" & Format(ar(k, 2), "0")
    
24.         Next
    
25.         x = x + jg: x = IIf(x >= 2 * n, x + 1, x): x = ((x - 1) Mod 2 * n) + 1
    
26.     Next
    
27.     Sheet1.Cells.ClearContents
    
28.     Sheet1.[a1].Resize(lunci, n).Columns.AutoFit
    
29.      Sheet1.[a1].Resize(n, lunci) = WorksheetFunction.Transpose(br)
    
30. End Sub

复制代码