Spielplan für ein Doppelturnier in Excel erstellen?

Ich möchte einen Spielplan für ein Tennis Doppelturnier in Excel erstellen.

Dazu möchte ich (1) die Spielerpaarungen zusammenstellen. Es gibt zwei Töpfe (männlich/weiblich oder aktiv/passiv) mit jeweils 12 Spieler/innen, z.B. A1-12 und P1-12. Die Spielerpaarungen sollen so zusammengestellt werden dass immer ein aktiver mit einem passiven spielt und die Paarungen nicht doppelt vorkommen. Das müßte dann in Summe 144 Spielerpaarungen geben oder 12 Runden mit je 12 Paarungen oder 6 Spielen?

Ich möchte jetzt als nächstes (2) die Matches bilden. D.h. bei 12 Paarungen pro Runde habe ich 6 Matches (Doppelspiel). Dabei soll die Vorgabe sein, dass es keine Überschneidungen gibt, d.h. jedes Doppelpaar soll möglichst immer gegen ein anderes Doppelpaar spielen, z.B. A2/P4 gegen A8/P1. Das Kriterium keine Überschneidung soll für alle 4 Spieler gelten. D.h. spielt wie im Beispiel oben A2/P4 gegen A8/P1 sollte es keine spätere Paarung geben wie A2/P6 gegen A8/P10 (A2 hat gegen A8 schon einmal gespielt) oder A2/P4 gegen A3/P2 (A2 hat mit P4 schon einmal gespielt).

Bin ich mal gespannt ob Excel dass kann ... obwohl ich denke Excel wird es können, ich verstehe es hoffentlich dann auch.

Würde mich über Antworten freuen. Gerne auch Formeln, Excel Arbeitsblätter, etc.

Grüße, Thomas

Answer 1

[gfntom]

Ja, das kann man mit Excel machen - dafür ist aber Excel nicht gedacht. Excel ist für sich keine Programmiersprache!

Da ich deinen Ausführungen nicht im Detail folgen kann, versuche ich erst gar nicht, einen Vorschlag zu machen.

Comments

[tomy76]

OK Du weißt dass es Excel kann aber Du kannst meinen Ausführungen nicht ganz folgen ... klingt für mich schon mal nicht logisch.

[gfntom]

@tomy76

Anstatt dass du nachfragst, was ich nicht verstehe, wirst du patzig. Das sind die Richtigen.

Ich hätte meinen Vorschlag fertig und wollte ihn gerade hier posten.

Aber wenn es für dich "nicht logisch" ist, lasse ich es wohl lieber, oder?

Schönen Tag noch

Answer 2

[DanKirpan]

Hallo,

ich bin nicht sicher ob ich richtig verstehe was du vorhast aber evtl hilft dir das Folgende trotzdem weiter :?

Da ich auf 3600 (((12^2-24)/2)^2) mögliche Matches komme schien mir eine zufällige Auswahl sinnvoll und da Zufallszahlen einfacher zu bearbeiten sind, wenn man unbrauchbare aussortieren kann die Verwendung von VBA.

Das erste Makro bereitet ein Tabellenblatt auf um Zwischenzuspeichern welche Spieler bereits zusammen, gegeneinander und wie oft gespielt haben, das zweite generiert die Spieler nacheinander. Spieler 1 wird dabei aus den Spielern mit den wenigsten Spielen gewählt und Spieler 2-4 nacheinander aus den noch möglichen Partnern/Gegnern:

Sub Setup()
Dim Ber As Range, Zelle As Range
Dim Spa As Long, Zei As Long, i As Long
With ActiveSheet
    Set Ber = .Range("A1:Z25")
    Zei = 1
    Spa = 1
    .Range("AA:AE").ClearContents
    .Range("AA1") = "Match"
    For i = 1 To 4
        .Range("AA1").Offset(0, i).Value = "Spieler " & i
    Next i
    
    For i = 1 To 24
        If i <= 12 Then
            Ber.Cells(1, i + 1).Value = "A" & Application.WorksheetFunction.Text(i, "00")
            Ber.Cells(i + 1, 1).Value = "A" & Application.WorksheetFunction.Text(i, "00")
        Else
            Ber.Cells(1, i + 1).Value = "P" & Application.WorksheetFunction.Text(i - 12, "00")
            Ber.Cells(i + 1, 1).Value = "P" & Application.WorksheetFunction.Text(i - 12, "00")
        End If
            Ber.Cells(1, 26).Value = "Anzahl Spiele"
            Ber.Cells(i + 1, 26).FormulaR1C1 = "=COUNTIF(C[2]:C[5],RC[-25])"
    Next i
    
    For Each Zelle In Ber
        If (Zelle.Row > Ber.Row And Zelle.Column > Ber.Column And Zelle.Column < 26) Then
            If Ber.Cells(Ber.Row, Zelle.Column).Value = Ber.Cells(Zelle.Row, Ber.Column).Value Then
                Zelle.Value = "nein"
            Else
                Zelle.Value = "ja"
            End If
        End If
    Next Zelle
    .Columns("A:Z").EntireColumn.AutoFit
End With


End Sub


Sub Auswahl()
Dim gultPart As Boolean, gultGeg As Boolean, nVersuch As Boolean
Dim i As Long, dCo As Long
Dim lZei As Long, Zufall As Long, Spa As Long, Zei As Long
Dim S1 As String, S2 As String, S3 As String, S4 As String, S5 As String
Dim Status As String, A As String, B As String
Dim SpielZahl As Range, Zelle As Range, Partnerwahl As Range, GPV As Range, GPVS As Range, GPVZ As Range
Dim GPVZU As Range


Dim Anz As Long, Zahler As Long, inf As Long, infCO As Long, CancWdh As Long, CancWdhCO As Long
infCO = 99999 'Anzahl Schleifendurchläfe nach denen automatisch abgebrochen wird
CancWdhCO = 99 'Anzahl versuchter wiederholungen
Anz = 6 ' festlegen wieviele generiert werden sollen




Dim ja As String, nein As String, Partner As String, Gegner As String
ja = "ja"
nein = "nein"
Partner = "P"
Gegner = "G"


Zahler = 0
inf = 0
CancWdh = 0


Set SpielZahl = ActiveSheet.Range("Z1:Z25")
Set GPV = ActiveSheet.Range("A1:Y25")
Set GPVS = ActiveSheet.Range("A1:A25")
Set GPVZ = ActiveSheet.Range("A1:Y1")


Do Until Zahler = Anz
nVersuch = False
Zahler = Zahler + 1
    
    inf = inf + 1
    If inf >= infCO Then
        MsgBox "Unendliche Schleife vermutet, abgebrochen."
        End
    End If


With Application.WorksheetFunction
'Spieler 1 Festlegen aus den Personen mit der wenigsten Anzahl vergebener Spieler
    Randomize
    Zufall = Int((.CountIf(SpielZahl, .Min(SpielZahl))) * Rnd + 1)
    dCo = 0
    For Each Zelle In SpielZahl
        If Zelle.Value = .Min(SpielZahl) Then
            dCo = dCo + 1
            If dCo = Zufall Then
                S1 = ActiveSheet.Range("A" & Zelle.Row)
                Exit For
            End If
        End If
    Next Zelle
'Spieler 2 festlegen
    S2 = S1
    If Left(S1, 1) = "P" Then
        Set Partnerwahl = ActiveSheet.Range("A1:A13")
    Else
        Set Partnerwahl = ActiveSheet.Range("A14:A25")
    End If
    
    Spa = .Match(S1, ActiveSheet.Range("A1:Y1"), 0)
    If Left(S1, 1) = "A" Then
        Set GPVZU = ActiveSheet.Range(ActiveSheet.Cells(14, Spa), ActiveSheet.Cells(25, Spa))
    Else
        Set GPVZU = ActiveSheet.Range(ActiveSheet.Cells(2, Spa), ActiveSheet.Cells(13, Spa))
    End If
        
    gultPart = False
    
    Do Until gultPart
        inf = inf + 1
        If inf >= infCO Then
            MsgBox "Unendliche Schleife vermutet, abgebrochen."
            End
        End If
    
        If .CountIf(GPVZU, ja) + .CountIf(GPVZU, Partner) = 0 Then
            'MsgBox "Kein gültiger Partner für Spieler " & S1 & " möglich."
            CancWdh = CancWdh + 1
            nVersuch = True
            'End
            GoTo neuVersuch
        End If
        Randomize
        Zufall = Int((.CountIf(GPVZU, ja) + .CountIf(GPVZU, Partner)) * Rnd + 1)
        dCo = 0
        For Each Zelle In GPVZU
            If Zelle.Value = ja Or Zelle.Value = Partner Then
                dCo = dCo + 1
                If dCo = Zufall Then
                    S2 = ActiveSheet.Range("A" & Zelle.Row)
                    gultPart = True
                    Exit For
                End If
            End If
        Next Zelle
    Loop
    
'Spieler 3 festlegen
    S3 = S1
    gultGeg = False
    Do Until gultGeg
        inf = inf + 1
        If inf >= infCO Then
            MsgBox "Unendliche Schleife vermutet, abgebrochen."
            End
        End If
        
        dCo = 0
        For Each Zelle In GPVS 'Anzahl gültiger Gegner bestimmen
            'gültiger Gegner S1
            If Zelle.Offset(0, .Match(S1, GPVZ, 0) - 1).Value = ja Or Zelle.Offset(0, .Match(S1, GPVZ, 0) - 1).Value = Gegner Then
                'gültiger Gegner S2
                If Zelle.Offset(0, .Match(S2, GPVZ, 0) - 1).Value = ja Or Zelle.Offset(0, .Match(S2, GPVZ, 0) - 1).Value = Gegner Then
                    dCo = dCo + 1
                End If
            End If
        Next Zelle
        
        If dCo = 0 Then
            'MsgBox "Kein gültiger Gegner für das Spielerpaar " & S1 & "+" & S2 & " möglich."
            CancWdh = CancWdh + 1
            nVersuch = True
            'End
            GoTo neuVersuch
        End If
        
        Randomize
        Zufall = Int((dCo) * Rnd + 1)
        dCo = 0
        
        For Each Zelle In GPVS 'Gegner bestimmen
            'gültiger Gegner S1
            If Zelle.Offset(0, .Match(S1, GPVZ, 0) - 1).Value = ja Or Zelle.Offset(0, .Match(S1, GPVZ, 0) - 1).Value = Gegner Then
                'gültiger Gegner S2
                If Zelle.Offset(0, .Match(S2, GPVZ, 0) - 1).Value = ja Or Zelle.Offset(0, .Match(S2, GPVZ, 0) - 1).Value = Gegner Then
                    dCo = dCo + 1
                    If dCo = Zufall Then
                        S3 = Zelle.Value
                        gultGeg = True
                        Exit For 'zelle
                    End If
                End If
            End If
        Next Zelle
    Loop
    
'Spieler 4 festlegen
    S4 = S1
    gultGeg = False
    gultPart = False
    If Left(S3, 1) = "P" Then
        Set Partnerwahl = ActiveSheet.Range("A1:A13")
    Else
        Set Partnerwahl = ActiveSheet.Range("A14:A25")
    End If
    
    Do Until gultGeg And gultPart
        inf = inf + 1
        If inf >= infCO Then
            MsgBox "Unendliche Schleife vermutet, abgebrochen."
            End
        End If
        
        dCo = 0
        For Each Zelle In Partnerwahl 'Anzahl gültiger Gegner & Partner bestimmen
            'gültiger Gegner S1
            If Zelle.Offset(0, .Match(S1, GPVZ, 0) - 1).Value = ja Or Zelle.Offset(0, .Match(S1, GPVZ, 0) - 1).Value = Gegner Then
                'gültiger Gegner S2
                If Zelle.Offset(0, .Match(S2, GPVZ, 0) - 1).Value = ja Or Zelle.Offset(0, .Match(S2, GPVZ, 0) - 1).Value = Gegner Then
                    'gültiger Partner S3
                    If Zelle.Offset(0, .Match(S3, GPVZ, 0) - 1).Value = ja Or Zelle.Offset(0, .Match(S3, GPVZ, 0) - 1).Value = Partner Then
                        dCo = dCo + 1
                    End If
                End If
            End If
        Next Zelle
        
        If dCo = 0 Then
            'MsgBox "Kein gültiger Partner für " & S3 & " gegen das Spielerpaar " & S1 & "+" & S2 & " möglich."
            CancWdh = CancWdh + 1
            nVersuch = True
            'End
            GoTo neuVersuch
        End If
        
        Randomize
        Zufall = Int((dCo) * Rnd + 1)
        dCo = 0
        
        For Each Zelle In Partnerwahl 'letzten gültiger Gegner & Partner bestimmen
            'gültiger Gegner S1
            If Zelle.Offset(0, .Match(S1, GPVZ, 0) - 1).Value = ja Or Zelle.Offset(0, .Match(S1, GPVZ, 0) - 1).Value = Gegner Then
                'gültiger Gegner S2
                If Zelle.Offset(0, .Match(S2, GPVZ, 0) - 1).Value = ja Or Zelle.Offset(0, .Match(S2, GPVZ, 0) - 1).Value = Gegner Then
                    'gültiger Partner S3
                    If Zelle.Offset(0, .Match(S3, GPVZ, 0) - 1).Value = ja Or Zelle.Offset(0, .Match(S3, GPVZ, 0) - 1).Value = Partner Then
                        dCo = dCo + 1
                        If dCo = Zufall Then
                            S4 = Zelle.Value
                            gultGeg = True
                            gultPart = True
                            Exit For 'zelle
                        End If
                    End If
                End If
            End If
        Next Zelle
    Loop
End With '.Worksheetfunction
    
'sortieren zu A+P vs A+P
If Left(S1, 1) = "P" Then
    S5 = S1
    S1 = S2
    S2 = S5
End If


If Left(S3, 1) = "P" Then
    S5 = S3
    S3 = S4
    S4 = S5
End If


    'MsgBox S1 & Chr(10) & S2 & Chr(10) & S3 & Chr(10) & S4
    'MsgBox S1 & "+" & S2 & " vs " & S3 & "+" & S4


With ActiveSheet
'Match & Spieler auflisten
    lZei = .Range("AA" & .Rows.Count).End(xlUp).Row + 1
    .Range("AA" & lZei) = S1 & "+" & S2 & " vs " & S3 & "+" & S4
    .Range("AB" & lZei) = S1
    .Range("AC" & lZei) = S2
    .Range("AD" & lZei) = S3
    .Range("AE" & lZei) = S4
End With


'GPV aktualisieren
    dCo = 0
    For Each Zelle In GPV
        A = Application.WorksheetFunction.Index(GPV, 1, Zelle.Column)
        B = Application.WorksheetFunction.Index(GPV, Zelle.Row - GPV.Row + 1, 1)
        Status = Zelle.Value
        
        'spielen zusammen
        If (A = S1 And B = S2) Or (A = S2 And B = S1) Or (A = S3 And B = S4) Or (A = S4 And B = S3) Then
            If Status = Partner Then 'Partner -> hatten bereits gegeneinander gespielt -> keine weitere Interaktion der beiden
                Zelle.Value = nein
            Else
                Zelle.Value = Gegner
            End If
        End If
        
        'sind Gegner
        If (A = S1 And B = S3) Or (A = S1 And B = S4) Or (A = S2 And B = S3) Or (A = S2 And B = S4) _
            Or (B = S1 And A = S3) Or (B = S1 And A = S4) Or (B = S2 And A = S3) Or (B = S2 And A = S4) Then
            If Status = Gegner Then 'Gegner -> hatten bereits miteinander gespielt -> keine weitere Interaktion der beiden
                Zelle.Value = nein
            Else
                Zelle.Value = Partner
            End If
        End If
    Next Zelle
neuVersuch:
If nVersuch Then
    Zahler = Zahler - 1
End If


If CancWdh = CancWdhCO Then
    MsgBox "Abgebrochen nachdem " & CancWdhCO & " mal kein neuer Eintrag gefunden wurde."
    End
End If
Loop


End Sub