Guten Morgen M.O.,
vielen lieben Dank für deine Antwort. Werde es mit suchen ersetzen machen.
Eine Frage habe ich noch, möchte diese aber nicht als neue Frage stellen, da ich schon mehrmals diesbezüglich gefragt habe und leider keine Antwort erhalten habe. Es geht um diese Datei die ich vom normalen Dartspiel in einer neue Spielvariante verändert habe und diese Dart Datei hast du mir einmal erstellt. Ich suche den Fehler und finde ihn nicht. es geht um die Einträge der Punkte. Für Spieler 1 Wurf 1 schreibt er K19 Wurf 2 in L19 Wurf 3 in M19 alles Ok. dann Spieler 2 von N19 auch Ok bis P19 jetzt ist Spieler 1 wieder am Wurf und dieser Wert wird in N19 übernommen anstatt in K19.
Wenn du möchtest, könntest du mir bei der Lösung helfen.
Das ist das VBA dazu
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
ActiveSheet.Unprotect
Dim lngSpieler As Long
Dim lngSpalte As Long
Dim lngWurf As Long
Dim lngDT As Long
Dim strSpiel As String
Dim lngZeile As Long
Dim lngSZeile As Long
Dim lngWZeile As Long
Dim lngWSpalte As Long
Dim lngAnsage As Long
Dim bUeberw As Boolean
Dim i As Long
'Nur bei Klick im Bereich von K19 bis d12 ausführen
If Intersect(Target, Range("i2, H1, a2:d12")) Is Nothing Then Exit Sub
'nicht in Zelle klicken
Cancel = True
'Bei Klick in I2 = Game on - Ansage starten
If Target.Address = "$I$2" Then
lngAnsage = 998
'Ansage starten
Start_Ansage (lngAnsage)
'dann Makro wieder verlassen
Exit Sub
End If
'Nummer des Spielers einlesen
lngSpieler = Range("j1").Value
'Spalte für Spieler ermitteln; Spieler stehen in Spalten K bis RB
lngSpalte = 8 + lngSpieler * 3
'Prüfen ob Zelle verbunden ist
If Target.Cells.Count > 1 Then
'falls ja dann die entsprechenden Werte in Variable schreiben
If Target.Address = "$f$12:$g$12" Then lngWurf = 25
If Target.Address = "$f$12:$g$12" Then
lngWurf = 50 '50 Zuweisen
lngDT = 2 'Marker für Doppel setzen
End If
'prüfen, ob Fehlwurf
If Target.Address = "$e$12:$f$12" Then lngWurf = 0
Else
'falls kein Fehlwurf
lngWurf = Target.Value
If Target.Column = 2 Or Target.Column = 5 Then lngDT = 2 'Marker für Doppel setzen
If Target.Column = 3 Or Target.Column = 6 Then lngDT = 3 'Marker für Triple setze
End If
'wenn Überworfen,
If Cells(6, lngSpalte) - lngWurf < 0 Then
'dann Wurfergebnis auf Null setzen
lngWurf = 0
'Marker für überworfen setzen
bUeberw = True
End If
'wenn Überworfen, dann Wurfergebnis auf Null setzen
If Cells(6, lngSpalte) - lngWurf < 0 Then lngWurf = 0
'Zeile für Würfe suchen
'dazu die Nr des Spielers herausfinden und damit Suchstring erstellen
strSpiel = "Sp" & Range("J1")
'Zeile für Spiel suchen
For lngZeile = 19 To 442
If Cells(lngZeile, 1).Value = strSpiel Then
lngSZeile = lngZeile
Exit For
End If
Next lngZeile
'Zeile für Eintrag der Würfe suchen
lngWZeile = 19 + WorksheetFunction.RoundDown(Cells(lngSZeile, 10).Value / 3, 0)
'Spalte für den Eintrag der Würfe ermitteln
lngWSpalte = WorksheetFunction.RoundDown(Cells(lngSZeile, 10).Value / 3, 0) + 2
'Würfe der Runde auf Null setzen, wenn überworfen
If bUeberw = True Then
For i = 1 To Cells(lngSZeile, lngWSpalte).Value
Cells(lngWZeile, lngSpalte + Cells(lngSZeile, lngWSpalte).Value - i) = 0
Next i
End If
'Anzahl Würfe erhöhen
Cells(lngSZeile, lngWSpalte) = Cells(lngSZeile, lngWSpalte).Value + 1
'Anzahl Doppel erhöhen
If lngDT = 2 Then Cells(11, lngSpalte + 1) = Cells(11, lngSpalte + 1).Value + 1
'Anzahl Triple erhöhen
If lngDT = 3 Then Cells(11, lngSpalte + 2) = Cells(11, lngSpalte + 2).Value + 1
'Würfe eintragen
Cells(lngWZeile, lngSpalte + Cells(lngSZeile, lngWSpalte).Value - 1) = lngWurf
'Daten für die Rücknahme des Wurfes in das Array schreiben
arrRueck(0) = lngSZeile 'Zeile für Eintrag des Wurfs
arrRueck(1) = lngWSpalte 'Spalte für Eintrag des Wurfs
arrRueck(2) = lngSpalte 'Spalte für Spieler
arrRueck(3) = lngWZeile 'Zeile für Ergebnis des Wurfs
arrRueck(4) = lngSpalte + Cells(lngSZeile, lngWSpalte).Value - 1 'Spalte für Ergebnis des Wurfes
arrRueck(5) = lngDT 'Doppel oder Triple
'hier für die Ansage und Anzeige
'prüfen, ob Überworfen
If bUeberw = True Then
Start_Ansage (0)
Else
'prüfen ob Anzahl der Würfe ohne Rest durch 3 Teilbar ist oder Checkout vorliegt
If Cells(lngSZeile, lngWSpalte).Value Mod 3 = 0 And Cells(1, lngSpalte).Value <> "Checkout" Then
'Anzeige
Range("H6") = "Geworfen: " & Cells(arrRueck(3), arrRueck(4)).Value + Cells(arrRueck(3), arrRueck(4) - 2) + Cells(arrRueck(3), arrRueck(4) - 1) & vbLf & "Rest: " & Cells(6, arrRueck(4) - 2).Value
lngAnsage = Cells(lngWZeile, lngSpalte + Cells(lngSZeile, lngWSpalte).Value - 1) + Cells(lngWZeile, lngSpalte + Cells(lngSZeile, lngWSpalte).Value - 2) + Cells(lngWZeile, lngSpalte + Cells(lngSZeile, lngWSpalte).Value - 3)
Start_Ansage (lngAnsage)
'Anzeige nach 5 Sekunden wieder löschen
Application.Wait Now + TimeValue("00:00:3")
Range("H6") = ""
End If
End If
'Checkout; 999 = Game over
If Cells(1, lngSpalte).Value = "Checkout" Then Start_Ansage (999)
If Not Intersect(Target, Range("B2:B11,E2:E12,C12")) Is Nothing Then
'Doppel
Cells(1 + Range("J1").Value, 422) = "ja"
Else
'kein Doppel
Cells(1 + Range("J1").Value, 422) = "nein"
End If
ActiveSheet.Protect
End Sub
Gruß Adde
