Hallo Adde,
ja, da hatte ich einen Denkfehler.
So sollte das Makro jetzt 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 lngAnzahl As Long
Dim lngAnsage As Long
Dim i As Long
'Nur bei Klick im Bereich von IK2 bis IP12 ausführen
If Intersect(Target, Range("ie1, ij3, ik2:in12")) Is Nothing Then Exit Sub
'nicht in Zelle klicken
Cancel = True
'Bei Klick in IE1 = Game on - Ansage starten
If Target.Address = "$IE$1" Then
lngAnsage = 998
'Ansage starten
Start_Ansage (lngAnsage)
'dann Makro wieder verlassen
Exit Sub
End If
'Arbeitsblatt entsperren
ActiveSheet.Unprotect
'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 = "$IK$12:$IL$10" Then lngWurf = 25
If Target.Address = "$IM$12:$I0$12" Then
lngWurf = 50 '50 Zuweisen
lngDT = 2 'Marker für Doppel setzen
End If
End If
'prüfen, ob Fehlwurf
If Target.Address = "$Ij$3" Then
lngWurf = 0
Else
'falls kein Fehlwurf
lngWurf = Target.Value
If Target.Column = 246 Or Target.Column = 249 Then lngDT = 2 'Marker für Doppel setzen
If Target.Column = 247 Or Target.Column = 250 Then lngDT = 3 'Marker für Triple setze
End If
'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
'Anzahl der Würfe auslesen
'Prüfen, ob schon eine Zahl in Spalte J steht
If Cells(lngSZeile, 10) = "" Then
lngAnzahl = 0
Else
lngAnzahl = Cells(lngSZeile, 10).Value
End If
lngWZeile = 19 + WorksheetFunction.RoundDown(lngAnzahl / 3, 0)
'Spalte für den Eintrag der Würfe ermitteln
lngWSpalte = WorksheetFunction.RoundDown(lngAnzahl / 3, 0) - WorksheetFunction.RoundDown(lngAnzahl / 24, 0) * 8
If lngWSpalte = 0 Then lngWSpalte = 2
'Anzahl Würfe erhöhen
lngAnzahl = lngAnzahl + 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
Select Case lngAnzahl - Int(lngAnzahl / 3) * 3
Case Is = 0
Cells(lngWZeile, lngSpalte + 2) = lngWurf
arrRueck(4) = lngSpalte + 2 'Spalte für Ergebnis des Wurfes
Case Is = 1
Cells(lngWZeile, lngSpalte) = lngWurf
arrRueck(4) = lngSpalte
Case Is = 2
Cells(lngWZeile, lngSpalte + 1) = lngWurf
arrRueck(4) = lngSpalte + 1
End Select
'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
'Ansage Wurfergebnis
If lngWurf > 0 Then Start_Ansage (lngWurf)
'Checkout; 999 = Game over
If Range("IE1").Value = 230 Then Start_Ansage (999)
ActiveSheet.Protect
End Sub
Gruß
M.O.
