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
