Hallo Adde,
ich hatte das nicht getestet 
.
So sollte es aber funktionieren:
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
Dim bUeberw As Boolean
Dim i As Long
ActiveSheet.Unprotect
'Nur bei Klick im Bereich von A4 bis F14 ausführen
If Intersect(Target, Range("A4:F15, C16:D16")) Is Nothing Then Exit Sub
'nicht in Zelle klicken
Cancel = True
'Nummer des Spielers einlesen
lngSpieler = Range("g1").Value
'Spalte für Spieler ermitteln; Spieler stehen in Spalten K bis JZ
lngSpalte = 8 + lngSpieler * 3
'Doppel und Triple ermitteln
If Target.Column = 2 Then lngDT = 2 'Marker für Doppel setzen
If Target.Column = 3 Then lngDT = 3 'Marker für Triple setzen
'Prüfen ob Zelle verbunden ist
If Target.Cells.Count > 1 Then
'falls ja dann die entsprechenden Werte in Variable schreiben
If Target.Address = "$a$15:$b$15" Then lngWurf = 25
If Target.Address = "$C$15:$D$15" Or Target.Address = "$C$16:$D$16" Then
lngWurf = 50 '50 Zuweisen
lngDT = 2 'Marker für Doppel setzen
End If
'prüfen, ob Fehlwurf
If Target.Address = "$e$15:$f$15" Then lngWurf = 0
Else
If Target.Address = "$C$15" Then
lngWurf = 50 '50 Zuweisen
lngDT = 2 'Marker für Doppel setzen
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
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("G1")
'Zeile für Spiel suchen
For lngZeile = 19 To 286
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
'hier mit Doppel-IN, also nur dann eintragen, wenn 1 Doppel eingetragen wurde
If Cells(11, lngSpalte + 1).Value > 0 Then
'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
Else
'falls noch kein Doppel vorliegt, Ansage für Wurf in No Score ändern
lngWurf = 0
End If
'hier für die Ansage und Anzeige
'prüfen, ob Überworfen
If bUeberw = True Then
Start_Ansage (0)
Else
'Ansage Wurfergebnis
Start_Ansage (lngWurf)
If lngWurf > 0 Then Start_Ansage (lngWurf)
'Checkout; 999 = Game over
If Cells(1, lngSpalte).Value = "Checkout" Then Start_Ansage (999)
'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("KA12") = "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 2 Sekunden wieder löschen
Application.Wait Now + TimeValue("00:00:2")
Range("KA12") = ""
End If
End If
'Checkout; 999 = Game over
If Cells(1, lngSpalte).Value = "Checkout" Then Start_Ansage (999)
If Not Intersect(Target, Range("B2:B14,E2:E14,C15")) 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ß
M.O.
