sbRoundRobin

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

sbRndDecPlace

sbRoundToSum

Last modified 9mo ago

Copy link