Sulprobil
Search…
sbRoundRobin
Creates a round robin tournament
If you need to organize a round robin tournament you can use this subroutine.
Extract - just showing 5 leftmost columns of 33 in total
Please read my Disclaimer.
1
Option Explicit
2
3
Const CFirstOutputRow = 10
4
5
Sub sbRoundRobin()
6
'Creates a round robin tournament.
7
'https://berndplumhoff.gitbook.io/sulprobil/excel/excel-vba-solutions/sbroundrobin
8
'V0.2 PB 30-Dec-2020 (C) (P) by Bernd Plumhoff
9
Dim bPause As Boolean
10
Dim c As Long, c1 As Long 'Colours, 1 = White (Home game), 2 = Black (Away game)
11
Dim f As Long 'Player who has to pause
12
Dim i As Long, j As Long, k As Long 'Counters
13
Dim n As Long 'Number of players
14
Dim p As Long 'Number of players who can play
15
Dim r As Long 'Number of rounds
16
Dim t As Long 'Temporary storage during moves
17
18
'Initialize
19
n = Range("Number_of_Players")
20
c = Range("Player1_Game1")
21
wsR.Range(CFirstOutputRow & ":65536").EntireRow.Delete
22
23
If n < 2 Then
24
wsR.Cells(CFirstOutputRow, 1) = "'Number of players needs to be 2 or higher!"
25
Exit Sub
26
End If
27
If c < 1 Or c > 2 Then
28
wsR.Cells(CFirstOutputRow, 1) = "'Colour of player 1 in game 1 needs to 1 (White) or 2 (Black)!"
29
Exit Sub
30
End If
31
32
wsT.Cells.EntireRow.Delete
33
For i = 1 To n
34
wsT.Cells(1 + i, 1) = "'Player " & i
35
wsT.Cells(1, 1 + i) = "'Player " & i
36
wsT.Cells(1 + i, 1 + i) = "'X"
37
Next i
38
39
c1 = c
40
41
If n Mod 2 = 0 Then
42
bPause = False
43
p = n
44
r = n - 1
45
Else
46
bPause = True
47
p = n - 1
48
r = n
49
End If
50
ReDim a(1 To p) As Long
51
For i = 1 To p
52
a(i) = i
53
Next i
54
j = 0
55
If bPause Then
56
f = n
57
wsR.Cells(CFirstOutputRow, 2) = "'Free"
58
j = 1
59
End If
60
For i = 1 To p / 2
61
wsR.Cells(CFirstOutputRow, i + j + 1) = "'Table " & i
62
Next i
63
64
For i = 1 To r
65
66
'Output of of current game pairings
67
wsR.Cells(CFirstOutputRow + i, 1) = "'Round " & i
68
j = 2
69
If bPause Then
70
wsR.Cells(CFirstOutputRow + i, j) = "'" & f & " pauses"
71
j = j + 1
72
End If
73
If c1 = 1 Then
74
wsR.Cells(CFirstOutputRow + i, j) = "'" & a(1) & " - " & a(UBound(a))
75
wsT.Cells(1 + a(1), 1 + a(UBound(a))) = "'Round " & i & ", Table 1, white"
76
wsT.Cells(1 + a(UBound(a)), 1 + a(1)) = "'Round " & i & ", Table 1, black"
77
Else
78
wsR.Cells(CFirstOutputRow + i, j) = "'" & a(UBound(a)) & " - " & a(1)
79
wsT.Cells(1 + a(1), 1 + a(UBound(a))) = "'Round " & i & ", Table 1, black"
80
wsT.Cells(1 + a(UBound(a)), 1 + a(1)) = "'Round " & i & ", Table 1, white"
81
End If
82
j = j + 1
83
For k = 2 To UBound(a) / 2
84
If (c + k) Mod 2 = 0 Then
85
wsR.Cells(CFirstOutputRow + i, j) = "'" & a(k) & " - " & a(UBound(a) - k + 1)
86
wsT.Cells(1 + a(k), 1 + a(UBound(a) - k + 1)) = "'Round " & i & ", Table " & k & ", white"
87
wsT.Cells(1 + a(UBound(a) - k + 1), 1 + a(k)) = "'Round " & i & ", Table " & k & ", black"
88
Else
89
wsR.Cells(CFirstOutputRow + i, j) = "'" & a(UBound(a) - k + 1) & " - " & a(k)
90
wsT.Cells(1 + a(k), 1 + a(UBound(a) - k + 1)) = "'Round " & i & ", Table " & k & ", black"
91
wsT.Cells(1 + a(UBound(a) - k + 1), 1 + a(k)) = "'Round " & i & ", Table " & k & ", white"
92
End If
93
j = j + 1
94
Next k
95
96
'Move on to next round
97
If bPause Then
98
t = f
99
f = a(UBound(a))
100
For k = UBound(a) To 2 Step -1
101
a(k) = a(k - 1)
102
Next k
103
a(1) = t
104
Else
105
c1 = 3 - c1 'Switch colour for player 1
106
t = a(UBound(a))
107
For k = UBound(a) To 3 Step -1
108
a(k) = a(k - 1)
109
Next k
110
a(2) = t
111
End If
112
113
Next i
114
115
wsT.Cells.EntireColumn.AutoFit
116
117
End Sub
Copied!
sbRoundRobin.xlsm
38KB
Binary
Last modified 9mo ago
Copy link