Hallo Adde,
wenn ich das richtig sehe, hat sich außer dem Bereich für die Eingabe ja nichts geändert, d.h. die Punkte für die einzelnen Spieler sowie die Anzahl der Doppel und Tripple werden ja in den gleichen Zellen wie bisher ausgegeben.
Daher waren gar nicht so große Änderungen wie ich erst gedacht hatte notwendig.
Probiere mal den folgenden Code aus:
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
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
'Nur bei Klick im Bereich von CL5 bis CQ15 ausführen
If Intersect(Target, Range("J6,CL5:CQ15")) Is Nothing Then Exit Sub
'nicht in Zelle klicken
Cancel = True
'Bei Klick in J6 = Game on - Ansage starten
If Target.Address = "$J$6" Then
lngAnsage = 998
'Ansage starten
Start_Ansage (lngAnsage)
'dann Makro wieder verlassen
Exit Sub
End If
'Nummer des Spielers einlesen
lngSpieler = Range("G1").Value
'Spalte für Spieler ermitteln; Spieler stehen in Spalten K bis AH
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 = "$CL$15:$CM$15" Then lngWurf = 25
If Target.Address = "$CN$15:$CO$15" Then
lngWurf = 50 '50 Zuweisen
lngDT = 2 'Marker für Doppel setzen
End If
'prüfen, ob Fehlwurf
If Target.Address = "$CP$15:$CQ$15" Then lngWurf = 0
Else
'falls kein Fehlwurf
lngWurf = Target.Value
If Target.Column = 91 Or Target.Column = 94 Then lngDT = 2 'Marker für Doppel setzen
If Target.Column = 92 Or Target.Column = 95 Then lngDT = 3 'Marker für Triple setzen
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("G1")
'Zeile für Spiel suchen
For lngZeile = 19 To 128
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
'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
'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
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)
End If
'Checkout; 999 = Game over
If Cells(1, lngSpalte).Value = "Checkout" Then Start_Ansage (999)
End Sub
Die Ansage "No score" kommt allerdings nur, wenn überworfen wurde oder alle drei Würfe Null sind.
Bei den Zellen für 25, 50 und 0 habe ich jeweils 2 Zellen verbunden (genauso wie vorne).
Gruß
M.O.