sbRoundRobin

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