Abstract

If you need to organize a round robin tournament you can use this subroutine. It implements the circle method:

sbRoundRobin_Principle

An example for 6 players:

sbRoundRobin_Pairings1

The VBA program - but not the worksheet function approach - also generates this kind of pairings table:

sbRoundRobin_Pairings2

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 – Solution with Excel Worksheet Functions

A simple solution approach with worksheet functions:

sbRoundRobin_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.

Please read my Disclaimer.

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.

Please read my Disclaimer.

Option Explicit

Const CFirstOutputRow = 10

Sub sbRoundRobin()
'Creates a round robin tournament.
'Source (EN): http://www.sulprobil.de/sbroundrobin_en/
'Source (DE): http://www.berndplumhoff.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

Download

Please read my Disclaimer.

sbRoundRobin.xlsm [35 KB Excel file, open and use at your own risk]