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.

Option Explicit
Const CFirstOutputRow = 10
Sub sbRoundRobin()
'Creates a round robin tournament.
'https://berndplumhoff.gitbook.io/sulprobil/excel/excel-vba-solutions/sbroundrobin
'V0.2 PB 30-Dec-2020 (C) (P) by Bernd Plumhoff
Dim bPause As Boolean
Dim c As Long, c1 As Long 'Colours, 1 = White (Home game), 2 = Black (Away game)
Dim f As Long 'Player who has to pause
Dim i As Long, j As Long, k As Long 'Counters
Dim n As Long 'Number of players
Dim p As Long 'Number of players who can play
Dim r As Long 'Number of rounds
Dim t As Long 'Temporary storage during moves
'Initialize
n = Range("Number_of_Players")
c = Range("Player1_Game1")
wsR.Range(CFirstOutputRow & ":65536").EntireRow.Delete
If n < 2 Then
wsR.Cells(CFirstOutputRow, 1) = "'Number of players needs to be 2 or higher!"
Exit Sub
End If
If c < 1 Or c > 2 Then
wsR.Cells(CFirstOutputRow, 1) = "'Colour of player 1 in game 1 needs to 1 (White) or 2 (Black)!"
Exit Sub
End If
wsT.Cells.EntireRow.Delete
For i = 1 To n
wsT.Cells(1 + i, 1) = "'Player " & i
wsT.Cells(1, 1 + i) = "'Player " & i
wsT.Cells(1 + i, 1 + i) = "'X"
Next i
c1 = c
If n Mod 2 = 0 Then
bPause = False
p = n
r = n - 1
Else
bPause = True
p = n - 1
r = n
End If
ReDim a(1 To p) As Long
For i = 1 To p
a(i) = i
Next i
j = 0
If bPause Then
f = n
wsR.Cells(CFirstOutputRow, 2) = "'Free"
j = 1
End If
For i = 1 To p / 2
wsR.Cells(CFirstOutputRow, i + j + 1) = "'Table " & i
Next i
For i = 1 To r
'Output of of current game pairings
wsR.Cells(CFirstOutputRow + i, 1) = "'Round " & i
j = 2
If bPause Then
wsR.Cells(CFirstOutputRow + i, j) = "'" & f & " pauses"
j = j + 1
End If
If c1 = 1 Then
wsR.Cells(CFirstOutputRow + i, j) = "'" & a(1) & " - " & a(UBound(a))
wsT.Cells(1 + a(1), 1 + a(UBound(a))) = "'Round " & i & ", Table 1, white"
wsT.Cells(1 + a(UBound(a)), 1 + a(1)) = "'Round " & i & ", Table 1, black"
Else
wsR.Cells(CFirstOutputRow + i, j) = "'" & a(UBound(a)) & " - " & a(1)
wsT.Cells(1 + a(1), 1 + a(UBound(a))) = "'Round " & i & ", Table 1, black"
wsT.Cells(1 + a(UBound(a)), 1 + a(1)) = "'Round " & i & ", Table 1, white"
End If
j = j + 1
For k = 2 To UBound(a) / 2
If (c + k) Mod 2 = 0 Then
wsR.Cells(CFirstOutputRow + i, j) = "'" & a(k) & " - " & a(UBound(a) - k + 1)
wsT.Cells(1 + a(k), 1 + a(UBound(a) - k + 1)) = "'Round " & i & ", Table " & k & ", white"
wsT.Cells(1 + a(UBound(a) - k + 1), 1 + a(k)) = "'Round " & i & ", Table " & k & ", black"
Else
wsR.Cells(CFirstOutputRow + i, j) = "'" & a(UBound(a) - k + 1) & " - " & a(k)
wsT.Cells(1 + a(k), 1 + a(UBound(a) - k + 1)) = "'Round " & i & ", Table " & k & ", black"
wsT.Cells(1 + a(UBound(a) - k + 1), 1 + a(k)) = "'Round " & i & ", Table " & k & ", white"
End If
j = j + 1
Next k
'Move on to next round
If bPause Then
t = f
f = a(UBound(a))
For k = UBound(a) To 2 Step -1
a(k) = a(k - 1)
Next k
a(1) = t
Else
c1 = 3 - c1 'Switch colour for player 1
t = a(UBound(a))
For k = UBound(a) To 3 Step -1
a(k) = a(k - 1)
Next k
a(2) = t
End If
Next i
wsT.Cells.EntireColumn.AutoFit
End Sub