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) = "'Spieleranzahl muss 2 oder höher sein!"
    Exit Sub
End If
If n > 16383 Then
    wsR.Cells(CFirstOutputRow, 1) = "'Spieleranzahl muss 16383 oder geringer sein!"
    Exit Sub
End If
If c < 1 Or c > 2 Then
    wsR.Cells(CFirstOutputRow, 1) = "'Die Farbe des Spielers 1 in Spiel 1 muss 1 (Weiß) oder 2 (Schwarz) sein!"
    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) = "Spieler " & i
    vT(1, 1 + i) = "Spieler " & 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) = "Frei"
    j = 1
End If
For i = 1 To p / 2
    vR(1, i + j + 1) = "Tisch " & i
Next i

For i = 1 To r

    'Output of of current game pairings
    vR(1 + i, 1) = "'Runde " & i
    j = 2
    If bPause Then
        vR(1 + i, j) = f & " pausiert"
        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))) = "Runde " & i & ", Tisch 1, Weiß"
        vT(1 + a(UBound(a)), 1 + a(1)) = "Runde " & i & ", Tisch 1, Schwarz"
    Else
        vR(1 + i, j) = "'" & a(UBound(a)) & " - " & a(1)
        vT(1 + a(1), 1 + a(UBound(a))) = "Runde " & i & ", Tisch 1, Schwarz"
        vT(1 + a(UBound(a)), 1 + a(1)) = "Runde " & i & ", Tisch 1, Weiß"
    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)) = "Runde " & i & ", Tisch " & k & ", Weiß"
            vT(1 + a(UBound(a) - k + 1), 1 + a(k)) = "Runde " & i & ", Tisch " & k & ", Schwarz"
        Else
            vR(1 + i, j) = "'" & a(UBound(a) - k + 1) & " - " & a(k)
            vT(1 + a(k), 1 + a(UBound(a) - k + 1)) = "Runde " & i & ", Tisch " & k & ", Schwarz"
            vT(1 + a(UBound(a) - k + 1), 1 + a(k)) = "Runde " & i & ", Tisch " & k & ", Weiß"
        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