39 Aufrufe
Gefragt in Tabellenkalkulation von addeguddi Mitglied (702 Punkte)

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

Deine Antwort

Dein angezeigter Name (optional):
Datenschutz: Deine Email-Adresse benutzen wir ausschließlich, um dir Benachrichtigungen zu schicken. Es gilt unsere Datenschutzerklärung.
Anti-Spam-Captcha:
Bitte logge dich ein oder melde dich neu an, um das Anti-Spam-Captcha zu vermeiden.
...