Ein nettes Hallo in die Runde der der Spezialisten des Forums,
benötige wieder einmal die Hilfe von einer Person von euch.
Hier geht es wieder um das Dartspiel:
Ich wurde angesprochen, da einige nicht so gut Dart spielen können, ob ich die +51 Regel erstellen könnte.
Das bedeutet:
Die Spielregel lautet so, wer zuerst die Zahl 301 oder 501 erreicht hat und das mit weniger als 51 Würfe, ist das Spiel zu ende. Doch wenn man mehr als 51 Würfe benötigt, soll das Spiel durch ein Wurf in die Mitte entschieden werden.
Nach jedem 3ten Wurf ist der nächste Spieler am Wurf und wenn der erste Spieler die Anzahl der Würfe von 51 und die Nachfolgende Spieler nicht die Zahl 301 oder 501 erreichen, wird wie oben erwähnt, mit Bullseys entschieden.
Ein netter Kollege von euch hat mir vor ca. 2 Jahren ein VBA erstellt, doch leider endet die nach dem 24 Wurf, habe schon zig Möglichkeiten probiert krieg es einfach nicht hin, vielleicht hat jemand eine Lösung für mich.
Die Spielernummer ändert sich nach jedem dritten Wurf :
Beispiel:
in J1 wird die Spielernummer 1 als erstes angezeigt und wenn dieser 3 Würfe getätigt hat erscheint die Zahl 2 für Spieler 2 Usw.
Das ist ein Teil vom VBA
'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 = "$a$12:$b$12" Then lngWurf = 25
If Target.Address = "$c$12:$d$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) = lngWurfHabe folgendes In VBA stehen
Noch ein Hinweis:
Die Würfe beginnen in der Zeile b19 und und endet in I19 Da in K19 die Zahl für den 1ten Wurf eingetragen wird.
Einer dieser Befehle müsste so verändert werden, das er die Würfe von jedem Spieler addiert.
Hoffe, ich habe mich verständlich ausgedrückt. Sollten Rückfragen sein, bitte schreibt mir.
Und in der Hoffnung eine Lösung zu erhalten verbleibe ich
mit lieben Grüßen an das Forum
Gruß Adde
