## 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 VBA program - but not the worksheet function approach - also generates this kind of pairings table:

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

## Appendix – Solution with Excel Worksheet Functions

A simple solution approach with worksheet functions:

An interesting fact: You can use this approach for (almost) any number of players. Just copy the rows down as far as necessary and the columns to the right until you see empty cells.

These formulas even work for pathological cases of 0 players, 1 player, and 2 players.

An explanation of how the formulas were derived for this approach you can find here: Named Ranges Used in a Different Way erklärt.

sbRoundRobin.xlsx [20 KB Excel file, open and use at your own risk]

## Appendix – VBA Solution - sbRoundRobin Code

Please note that you need to include the SystemState class.

``````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
Dim j                As Long
Dim k                As Long
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
``````