Hallo
Ich habe mir mit Hilfe der KI- ein kleines Turnierprogramm gebastelt. Eigentlich bin ich sehr zufrieden mit dem Ergebnis. Ein einziges anscheinend für mich und die KI unlösbares Problem hab ich jedoch. Ablauf sieht so aus.
Man trägt die Spieler ein, und vergibt Leben, in meinen Fall sind 3 Leben vergeben, jetzt hab ich hier das besagte Makro das ein wenig umgeschrieben gehört. Es soll so sein das wenn ich3 Leben vergebe ich auch 3 mal Losen kann, also solange losen bis die Gefahr ist das ein spieler auf 0 leben kommt und somit in der Runde ausscheiden könnte. Also es soll sein das ich solange die runden losen kann bis eben ein spieler in Gefahr ist auszuscheiden. Das tur das makro eigentlich auch perfekt. Nur leider ist es so ich hab Screenshots gemacht um es leichter zu verstehen, ich kann bei Turnierbeginn Losen bei 3 leben 3 x das ist ok, wenn ich aber jetzt nur eine Runde lose und ein Spiel mit einem sieger markiere lässt es mich erst weiterlosen wenn ich in der runde 1 alle spiele mit einem Sieger markiert habe obwohl, ich ja eigentlich 3 Runden losen könnte. Ich hätte eben gerne das ich immer solange losen kann solange kein spieler ausscheiden kann, unabhängig ob ich schon ein spiel eingetragen habe oder nicht.

Vielen Dank für eure Hilfe

Hier der Code mit KI erstellt:
Sub NeueZufallsRundeMitMarkierung_Herren()
Dim wsL As Worksheet, wsT As Worksheet, wsE As Worksheet
On Error Resume Next
Set wsL = Sheets("Leben")
Set wsT = Sheets("Turnier")
Set wsE = Sheets("Ergebnis")
On Error GoTo 0

If wsL Is Nothing Or wsT Is Nothing Or wsE Is Nothing Then
MsgBox "? Mindestens eines der benötigten Blätter ('Leben', 'Turnier', 'Ergebnis') fehlt!", vbCritical
Exit Sub
End If

Dim passwort As String: passwort = "" ' ? Passwort hier eintragen, falls nötig
wsT.Unprotect Password:=passwort
wsL.Unprotect Password:=passwort
wsE.Unprotect Password:=passwort

Dim startLeben As Long, rundenGelost As Long, lebenVerloren As Boolean
Dim i As Long

startLeben = Application.WorksheetFunction.Max(wsL.Range("B2:B" & wsL.Cells(wsL.Rows.count, 2).End(xlUp).Row))

For i = 1 To wsT.Cells(wsT.Rows.count, 1).End(xlUp).Row
If wsT.Cells(i, 1).MergeArea.Cells(1, 1).Value Like "Runde *" Then
rundenGelost = rundenGelost + 1
End If
Next i

For i = 2 To wsL.Cells(wsL.Rows.count, 1).End(xlUp).Row
If wsL.Cells(i, 2).Value startLeben Then
lebenVerloren = True
Exit For
End If
Next i

Dim offenePaarungGefunden As Boolean: offenePaarungGefunden = False
Dim zeile As Long, maxZeileT As Long: maxZeileT = wsT.Cells(wsT.Rows.count, 1).End(xlUp).Row
zeile = 1
Do While zeile = maxZeileT
If wsT.Cells(zeile, 1).MergeArea.Cells(1, 1).Value Like "Runde *" Then
zeile = zeile + 1
Do While wsT.Cells(zeile, 1).Value > ""
If wsT.Cells(zeile, 1).Interior.Color = xlNone Or wsT.Cells(zeile, 1).Interior.Color = 16777215 Then
offenePaarungGefunden = True
Exit Do
End If
zeile = zeile + 1
Loop
Else
zeile = zeile + 1
End If
Loop

If lebenVerloren And offenePaarungGefunden Then
MsgBox "Es wurden bereits Leben verloren!" & vbCrLf & _
"Bitte erst alle Paarungen der letzten Runde eintragen, bevor du neu losen kannst.", vbExclamation
wsT.Activate
Exit Sub
End If

If rundenGelost >= startLeben And Not lebenVerloren Then
MsgBox "Du hast bereits " & rundenGelost & " Runden gelost." & vbCrLf & _
"Da das Turnier mit " & startLeben & " Leben gestartet wurde, musst du jetzt erst Ergebnisse eintragen.", vbExclamation
wsT.Activate
Exit Sub
End If

Dim spieler() As String, count As Long: count = 0
For i = 2 To wsL.Cells(wsL.Rows.count, 1).End(xlUp).Row
If wsL.Cells(i, 2).Value > 0 And wsL.Cells(i, 1).Value > "Freilos" Then
count = count + 1
ReDim Preserve spieler(1 To count)
spieler(count) = wsL.Cells(i, 1).Value
End If
Next i

If count = 1 Then
MsgBox "Turnier beendet!" & vbCrLf & vbCrLf & _
"Sieger: " & spieler(1) & vbCrLf & vbCrLf & _
"Du wirst jetzt zum Ergebnisblatt weitergeleitet.", vbInformation, "Turniersieger"
wsE.Activate
Exit Sub
End If

If count = 0 Then Exit Sub

Dim bereitsGespielt() As String
Dim paarungIndex As Long: paarungIndex = 0

For i = 1 To wsT.Cells(wsT.Rows.count, 1).End(xlUp).Row
If wsT.Cells(i, 1).MergeArea.Cells(1, 1).Value Like "Runde *" Then
Dim rundenNummer As Long
rundenNummer = Val(Split(wsT.Cells(i, 1).Value, " ")(1))
If rundenNummer = startLeben Then
Dim z As Long: z = i + 1
Do While wsT.Cells(z, 1).Value > ""
Dim p1 As String, p2 As String
p1 = wsT.Cells(z, 1).Value
p2 = wsT.Cells(z, 2).Value
If p2 > "Freilos" Then
paarungIndex = paarungIndex + 1
ReDim Preserve bereitsGespielt(1 To paarungIndex)
bereitsGespielt(paarungIndex) = p1 & "|" & p2
paarungIndex = paarungIndex + 1
ReDim Preserve bereitsGespielt(1 To paarungIndex)
bereitsGespielt(paarungIndex) = p2 & "|" & p1
End If
z = z + 1
Loop
End If
End If
Next i

Dim gültig As Boolean
Dim versuche As Long: versuche = 0
Dim tmp As String, j As Long
Do
gültig = True
Randomize
For i = count To 2 Step -1
j = Int(Rnd() * i) + 1
tmp = spieler(i)
spieler(i) = spieler(j)
spieler(j) = tmp
Next i

For i = 1 To count - 1 Step 2
If i + 1 = count Then
If PaarungExistiert(spieler(i), spieler(i + 1), bereitsGespielt) Then
gültig = False
Exit For
End If
End If
Next i

versuche = versuche + 1
If versuche > 100 Then

Exit Do
End If
Loop Until gültig

Dim zielZeile As Long: zielZeile = 10
Dim rundenZeilen As Long: rundenZeilen = (count \ 2) + (count Mod 2) + 2
wsT.Range("A" & zielZeile & ":C" & zielZeile + rundenZeilen - 1).Insert Shift:=xlDown

Dim rundeNummer As Long: rundeNummer = rundenGelost + 1

With wsT.Range("A" & zielZeile & ":B" & zielZeile)
.Merge
.Value = "Runde " & rundeNummer
.Interior.Color = RGB(204, 229, 255)
.Font.Bold = True
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.Borders.LineStyle = xlContinuous
.Borders.Weight = xlMedium
End With

With wsT.Cells(zielZeile, 3)
.Value = "Gerät"
.Interior.Color = RGB(204, 229, 255)
.Font.Bold = True
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.Borders.LineStyle = xlContinuous
.Borders.Weight = xlMedium
End With

Dim zeileT As Long: zeileT = zielZeile + 1

For i = 1 To count Step 2
wsT.Cells(zeileT, 1).Value = spieler(i)
If i + 1 = count Then
wsT.Cells(zeileT, 2).Value = spieler(i + 1)
Else
wsT.Cells(zeileT, 2).Value = "Freilos"
wsT.Cells(zeileT, 1).Interior.Color = RGB(198, 239, 206) ' ? Spieler grün
wsT.Cells(zeileT, 2).Interior.Color = RGB(255, 199, 206) ' ? Freilos rot
End If

With wsT.Range("A" & zeileT & ":B" & zeileT)
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
End With

With wsT.Cells(zeileT, 3)
.Interior.Color = RGB(242, 242, 242)
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.Locked = False
End With

With wsT.Range("A" & zeileT & ":C" & zeileT).Borders
.LineStyle = xlContinuous
.Weight = xlThin
End With

zeileT = zeileT + 1
Next i

wsT.Columns("A").ColumnWidth = 30
wsT.Columns("B").ColumnWidth = 30
wsT.Columns("C").ColumnWidth = 10

wsT.Activate
wsT.Range("A" & zielZeile).Select

' Blattschutz wieder aktivieren
wsT.Protect Password:=passwort, UserInterfaceOnly:=True
wsL.Protect Password:=passwort, UserInterfaceOnly:=True
wsE.Protect Password:=passwort, UserInterfaceOnly:=True

MsgBox "? Runde " & rundeNummer & " wurde erfolgreich erstellt!", vbInformation
wsT.Activate
End Sub


Bei Bild 1 ohne einen Sieger zu markieren lässt es mich 3 mal losen

Bild 2 , man sieht alle spieler haben 3 leben

Bild 3 Sieger eingetragen , jetzt kann ich nicht weiterlosen

Bild 4 man sieht laut leben sollte es zum Losen gehen