Abstract
If you need to organize a round robin tournament you can use this subroutine. It implements the circle method:
An example for 6 players:
The program also generates this kind of pairings table:
Further Reading
Suksompong, W. (2018, April 11). Scheduling Asynchronous Round-Robin Tournaments. (External link!) https://arxiv.org/pdf/1804.04504.pdf
Abel, Finizio, Greig, Lewis (2003). Generalized whist tournament designs. (External link!) https://www.researchgate.net/publication/222140264_Generalized_whist_tournament_designs
Abel, Finizio, Greig, Morales (2008). Existence of (2, 8) GWhD(v) and (4, 8) GWhD(v) with v ≡ 0, 1 (mod 8). (External link!) https://www.researchgate.net/profile/Malcolm_Greig2/publication/257554633_Existence_of_2_8_GWhDv_and_4_8_GWhDv_with_v_equiv_01_mod_8/links/56f56a5f08ae7c1fda2ee68f.pdf
Richard A. DeVenezia’s homepage: (External link!) https://www.devenezia.com/downloads/round-robin/index.html
Ready-to-use tournament tables: (External link!) https://www.printyourbrackets.com/roundrobin.html
Appendix – sbRoundRobin Code
Please note that you need to include the SystemState class.
Please read my Disclaimer.
Option Explicit
Const CFirstOutputRow = 10
Sub sbRoundRobin()
'Creates a round robin tournament.
'Source (EN): http://www.sulprobil.com/sbroundrobin_en/
'Source (DE): http://www.bplumhoff.de/sbroundrobin_de/
'(C) (P) by Bernd Plumhoff 19-May-2023 PB V0.4
Dim bPause As Boolean
Dim c As Long
Dim 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
Dim state As SystemState
'Initialize
Set state = New SystemState
n = Range("Number_of_Players")
c = Range("Player1_Game1")
wsR.Range(CFirstOutputRow & ":" & 16382 + CFirstOutputRow).EntireRow.Delete
If n < 2 Then
wsR.Cells(CFirstOutputRow, 1) = "'Number of players needs to be 2 or higher!"
Exit Sub
End If
If n > 16383 Then
wsR.Cells(CFirstOutputRow, 1) = "'Number of players needs to be 16383 or less!"
Exit Sub
End If
If c < 1 Or c > 2 Then
wsR.Cells(CFirstOutputRow, 1) = "'Colour of player 1 in game 1 needs to be 1 (White) or 2 (Black)!"
Exit Sub
End If
wsT.Cells.EntireRow.Delete
ReDim vR(1 To n + 1, 1 To n / 2 + 2) As Variant
ReDim vT(1 To n + 1, 1 To n + 1) As Variant
For i = 1 To n
vT(1 + i, 1) = "Player " & i
vT(1, 1 + i) = "Player " & i
vT(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
vR(1, 2) = "Free"
j = 1
End If
For i = 1 To p / 2
vR(1, i + j + 1) = "Table " & i
Next i
For i = 1 To r
'Output of of current game pairings
vR(1 + i, 1) = "'Round " & i
j = 2
If bPause Then
vR(1 + i, j) = f & " pauses"
j = j + 1
End If
If c1 = 1 Then
vR(1 + i, j) = "'" & a(1) & " - " & a(UBound(a))
vT(1 + a(1), 1 + a(UBound(a))) = "Round " & i & ", Table 1, white"
vT(1 + a(UBound(a)), 1 + a(1)) = "Round " & i & ", Table 1, black"
Else
vR(1 + i, j) = "'" & a(UBound(a)) & " - " & a(1)
vT(1 + a(1), 1 + a(UBound(a))) = "Round " & i & ", Table 1, black"
vT(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
vR(1 + i, j) = "'" & a(k) & " - " & a(UBound(a) - k + 1)
vT(1 + a(k), 1 + a(UBound(a) - k + 1)) = "Round " & i & ", Table " & k & ", white"
vT(1 + a(UBound(a) - k + 1), 1 + a(k)) = "Round " & i & ", Table " & k & ", black"
Else
vR(1 + i, j) = "'" & a(UBound(a) - k + 1) & " - " & a(k)
vT(1 + a(k), 1 + a(UBound(a) - k + 1)) = "Round " & i & ", Table " & k & ", black"
vT(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))
j = 2
Else
c1 = 3 - c1 'Switch colour for player 1
t = a(UBound(a))
j = 3
End If
For k = UBound(a) To j Step -1
a(k) = a(k - 1)
Next k
a(j - 1) = t
Next i
wsR.Range(wsR.Cells(CFirstOutputRow, 1), wsR.Cells(CFirstOutputRow + n, 2 + n / 2)) = vR
wsT.Range(wsT.Cells(1, 1), wsT.Cells(n + 1, n + 1)) = vT
wsT.Cells.EntireColumn.AutoFit
End Sub
Please read my Disclaimer.
sbRoundRobin.xlsm [35 KB Excel file, open and use at your own risk]