Hallo Anonym,
was hältst du davon wenn ich dir meine Datei zukommen lasse? Denke dass du damit besser sehen kannst wo was ist. Das ist der Link. Noch ein kurzer Hinweis: J1 ändert sich nach 3 Würfe.
https://filehorst.de/d/eepvlgso
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("i3, J3, A2:D11")) Is Nothing Then Exit Sub
'nicht in Zelle klicken
Cancel = True
'Bei Klick in I2 = Game on - Ansage starten
If Target.Address = "$I$3" 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, 2).Value / 3, 0)
'Spalte für den Eintrag der Würfe ermitteln
lngWSpalte = WorksheetFunction.RoundDown(Cells(lngSZeile, 2).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, 2) = Cells(lngSZeile, 2).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
'Rest aus Anzahl der Würfe ermitteln und dann ent
Select Case Cells(lngSZeile, 2).Value Mod 3
Case Is = 0
'kein Rest, also 3. Wurf
Cells(lngWZeile, lngSpalte + 2) = lngWurf
Case Is = 1
'Rest 1, also 1. Wurf
Cells(lngWZeile, lngSpalte) = lngWurf
Case Is = 2
'Rest 2, also 2. Wurf
Cells(lngWZeile, lngSpalte + 1) = lngWurf
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
Start_Ansage (lngWurf)
'Checkout; 9991 = Game over
If Range("J15").Value = 210 Then Start_Ansage (9991)
ActiveSheet.Protect
End Sub
Gruß Adde
