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 program also generates this kind of pairings table:

sbRoundRobin_Pairings2

Literature

Suksompong, W. (2018, April 11). Scheduling Asynchronous Round-Robin Tournaments. Retrieved from (external link!) https://arxiv.org/pdf/1804.04504.pdf

Appendix – sbRoundRobin Code

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 30-Dec-2020 PB V0.2
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

Please read my Disclaimer.

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