Hallo und guten Tag an das tolle Team des Forum `s
Wer kann mir helfen?
Habe diese Frage zwar schon einmal gestellt aber in einem anderen zusammen Hang .Habe versucht Check Out aus diesem VBA in Basic heraus zunehmen und Spieler Abfrage zu verändern, kriege es nicht hin. Laufend kommen Fehlermeldungen.
Es geht noch einmal um eine Dartliste.
Mein Problem ist, dass wenn ich eine Spieler Nummer angebe, ab Spiel 25, nimmt er diese nicht an oder ich gebe für das Spiel 6 die Nummer 6 an und er gibt mir das Ergebnis im Spiel 30 an, da in diesem VBA eine Check out Angabe vorhanden und Spieler 1 ein Check out hat. Diese müsste heraus genommen werden. Damit ich fortlaufend die Spielernummer eingeben kann.
Noch ein Beispiel:
Wenn ich Spieler 6 angebe soll das Ergebnis ( Punktzahl ) in der Zelle Q5 erscheinen und nicht in
Q 12, da Spieler 1 ausgecheckt hat.
Meine Bitte wäre:
Von VBA sollte Check out heraus genommen werden und die Spiel - Nummer fortlaufend sein und wenn es möglich ist, wenn ich den Blattschutz einschalte, dass alle Makros und Steuerelemente aktiv sind.
Hoffe, dass ich mich richtig ausgedrückt habe.
Habe VBA weiter unten eingefügt und die Dartliste hochgeladen.
In der Hoffnung, das mir jemand helfen kann.
Liebe Grüße
Adde
Ps: Datei habe ich hoch geladen https://filehorst.de/d/clsdFzGf
Das ist das VBA Projekt
Private Sub SpinButton1_Change()
If SpinButton1.Value < 1 Then SpinButton1.Value = ActiveSheet.Range("c1")
If SpinButton1.Value > ActiveSheet.Range("c1") Then SpinButton1.Value = 1
ActiveSheet.Range("g1") = SpinButton1.Value
End Sub
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Dim lngSpieler As Long
Dim lngSpalte As Long
Dim lngEZeile As Long
Dim s As Long
Dim bCheckout As Boolean
Dim strSpiel As String
Dim lngSZeile As Long
Dim lngSSpalte As Long
Dim lngZeile As Long
Static lngErgebnis As Long
Dim lngWurf As Long
Dim lngWZeile
'Nur bei Klick im Bereich von B4 bis G14ausführen
If Not Intersect(Target, Range("B4:G14")) Is Nothing Then
'nicht in Zelle klicken
Cancel = True
'Ergebnis in Variable schreiben
'Prüfen ob Zelle verbunden ist
If Target.Cells.Count > 1 Then
'falls ja dann die entsprechenden Werte in Variable schreiben
If Target.Address = "$B$14:$C$14" Then lngWurf = 25
If Target.Address = "$D$14:$E$14" Then lngWurf = 50
Else
'ansonsten prüfen, ob Fehlwurf
If Target.Address = "$F$14:G14" Then
lngWurf = 0
Else
'falls kein Fehlwurf
lngWurf = Target.Value
End If
End If
'Nummer des Spielers einlesen
lngSpieler = Range("G1").Value
'Spalte für Spieler ermitteln; Spieler stehen in Spalten L bis S
lngSpalte = 11 + lngSpieler
'richtige Zeile für Ergebnis ermitteln
For lngZeile = 5 To 19 Step 7
bCheckout = False
'Spalten durchlaufen und prüfen, ob ein Spieler ausgecheckt hat
For s = 12 To 19
If Cells(lngZeile, s).Value = Cells(lngZeile - 1, s).Value Then
bCheckout = True
Exit For
End If
Next s
'falls keiner ausgecheckt hat, dann die gefundene Zeile in Variable für Ergebniszeile schreiben
If bCheckout = False Then
lngEZeile = lngZeile
Exit For
End If
Next lngZeile
'Nun Zeile für Würfe suchen
'dazu die Nr des Spiel herausfinden und damit Suchstring erstellen
strSpiel = "Sp" & Right(Cells(lngEZeile - 3, lngSpalte), Len(Cells(lngEZeile - 3, lngSpalte).Value) - 6)
'Zeile für Spiel suchen
For lngZeile = 18 To 77
If Cells(lngZeile, 1).Value = strSpiel Then
lngSZeile = lngZeile
Exit For
End If
Next lngZeile
'altes Ergebnis in Variable speichern
lngErgebnis = Cells(lngEZeile, lngSpalte).Value
'Zeile für die Eintragung der Würfe festlegen
Select Case lngEZeile
Case Is = 5
lngWZeile = 31
Case Is = 12
lngWZeile = 32
Case Is = 19
lngWZeile = 33
End Select
'Zähler für Würfe um 1 erhöhen
Cells(lngWZeile, lngSpalte) = Cells(lngWZeile, lngSpalte) + 1
'Punkte addieren
'Prüfen, ob überworfen
If Cells(lngEZeile, lngSpalte).Value + lngWurf <= Cells(lngEZeile - 1, lngSpalte).Value Then
'nur wenn nicht überworfen, Wurf hinzu addieren
Cells(lngEZeile, lngSpalte) = Cells(lngEZeile, lngSpalte).Value + lngWurf
'Ergebnis in Übersicht erhöhen
'dazu die betreffende Spalte festsetzen
lngSSpalte = WorksheetFunction.RoundUp(Cells(lngWZeile, lngSpalte).Value / 3, 0) + 1
Cells(lngSZeile, lngSSpalte).Value = Cells(lngSZeile, lngSSpalte).Value + lngWurf
End If
'Daten für die Rücknahme des Wurfes in das Array schreiben
arrRueck(0) = lngEZeile 'Zeile für Gesamtergebnis
arrRueck(1) = lngSpalte 'Spalte für Gesamtergebnis
arrRueck(2) = lngSZeile 'Zeile für Übersicht Ergebnisse
arrRueck(3) = lngSSpalte 'Spalte für Übersicht Ergebnisse
arrRueck(4) = lngWurf 'Ergebnis des Wurfes
arrRueck(5) = lngWZeile 'Zeile in der die Anzahl der Würfe geschrieben werden
End If
End Sub