Abstract

Falls Sie ein Turnier organisieren müssen, bei dem jeder einmal gegen jeden anderen Spieler spielen muss, können Sie dieses Programm verwenden. Es implementiert das sogenannte Rutschsystem:

sbRoundRobin_Prinzip

Ein Beispiel für 6 Spieler:

sbRoundRobin_Paarungen1

Das VBA Programm - jedoch nicht der Tabellenblattfunktionsansatz - generiert auch diese Art von Paarungstabelle:

sbRoundRobin_Paarungen2

Weiterführende Literatur

Suksompong, W. (2018, April 11). Scheduling Asynchronous Round-Robin Tournaments. (Externer Link!) https://arxiv.org/pdf/1804.04504.pdf

Abel, Finizio, Greig, Lewis (2003). Generalized whist tournament designs. (Externer 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). (Externer 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: (Externer link!) https://www.devenezia.com/downloads/round-robin/index.html

Direkt verwendbare Turniertabellen: (Externer link!) https://www.printyourbrackets.com/roundrobin.html

Appendix – Lösung mit Excel Tabellenblattfunktionen

Eine einfacher Lösungsansatz mit Tabellenblattfunktionen:

Rundenturnier_Tabellenblatt_Funktionen

Das Interessante ist: Sie können auch diesen Ansatz für (fast) beliebig viele Spieler verwenden. Kopieren Sie lediglich die Zeilen so weit wie nötig nach unten und die Spalten nach rechts, bis Sie Leerzellen erhalten.

Die Formeln funktionieren sogar für die pathologischen Fälle mit keinem, einem oder zwei Spielern.

Die Herleitung der Formeln wird unter Bereichsnamen einmal anders erklärt.

Bitte den Haftungsausschluss im Impressum beachten.

Rundenturnier.xlsx [20 KB Excel Datei, ohne jegliche Gewährleistung]

Appendix – Lösung mit VBA - Programmcode sbRoundRobin

Bitte beachten Sie, dass Sie die Klasse SystemState einfügen müssen.

Bitte den Haftungsausschluss im Impressum beachten.

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) = "'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

Download

Bitte den Haftungsausschluss im Impressum beachten.

Rundenturnier.xlsm [37 KB Excel Datei, ohne jegliche Gewährleistung]