215 Aufrufe
Gefragt in Tabellenkalkulation von addeguddi Experte (2.6k Punkte)

Habe diese Frage schon einmal gestellt, habe auch hier im Forum das schon gelesen (

, doch mein Problem ist wenn ich das als Vorlage in VBA einfüge kriege ich immer einen Fehlmeldung da es sich  hierbei wahrscheinlich um die Zuordnung der Zellen und Zeilen geht und ich leider nicht weiß wie ich das zuordnen soll, wende ich mich nochmals mit der Bitte zur Unterstützung an euch.

Mein VBA  wird nach jedem Wurf die Punktzahl angesagt. das habe ich hin bekommen.

 Das ist mein VBA:

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
 'hier für die Ansage und Anzeige
'prüfen, ob Überworfen
If bUeberw = True Then
  Start_Ansage (0)
Else
'prüfen, ob Überworfen
If bUeberw = True Then
  Start_Ansage (0)
End If
'Checkout; 999 = Game over
If Cells(1, lngSpalte).Value = "Checkout" Then Start_Ansage (999)
Start_Ansage (lngWurf)

   '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
'Checkout; 999 = Game over
If Cells(1, lngSpalte).Value = "Checkout" Then Start_Ansage (999)
End If
End If
End Sub

In der Hoffnung eine Lösung zu erhalten.

Ich schreibe jetzt schon einmal Danke im voraus.

Gruß Adde

7 Antworten

0 Punkte
Beantwortet von vbastler Mitglied (316 Punkte)

Moin Adde,

bevor ich lange Deinen Code analysiere (den du hier übrigens über das Format-Dropdown Normal auch leicht als solchen kennzeichnen kannst, womit er leichter lesbar wird) habe ich mal eben eine kleine Lösung gebastelt. Dazu baust Du Dir bitte eine einfache Tabelle mit folgenden Inhalten:

Zeile 1: Spalte C = Spieler A, Spalte E = 501, Spalte G = Spieler B

Zeile 2: B&F = Single, C&G = Double, D&H = Triple

Spalte E 3-22 die Werte 1 - 20, in die Zeile 23-25 die Wert 25, 50 und 0

Dann kopierst Du den folgenden Code in ein Arbeitsblatt und Rest übernimmt Deine Maus. Ab jetzt regiert der Doppelklick!

Ein Doppelklick in die Spalten B-D und F-H errechnet den Wert des Wurfs, und schreibt nach jedem dritten Wurf die Summe in die erste Zeile A & I. Dazu erscheint eine MessageBox, die du dann durch Deinen Code für das Schallereignis austauschen/ergänzen kannst.

Ein Doppelklick auf die 501 setzt alle Einträge wieder zurück. Du kannst ihn aber auch z.B. durch 301 ersetzen, falls Du diese Variante spielen willst.

Option Explicit
Public iDarts As Integer, iSum As Integer

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Dim iValue As Integer, rngLeft As Range, rngRight As Range

Cancel = True

'Range für die Werte pro Dart
Set rngLeft = Range("A3:A5")
Set rngRight = Range("I3:I5")

'Reset der aktuellen Spielwerte
If Target.Address = ("$E$1") Then
    rngLeft.Clear
    rngRight.Clear
    Cells(1, 1).Clear
    Cells(1, 9).Clear
End If

'Berechnung des Werts pro Dart je Spieler
Select Case Target.Row
    Case 3 To 22
        Select Case Target.Column
            Case 2, 3, 4    'Spieler A
                iDarts = iDarts + 1
                iValue = (Cells(Target.Row, 5) * (Target.Column - 1))
                iSum = iSum + iValue
                Cells(iDarts + 2, 1) = iValue
            Case 6, 7, 8    'Spieler B
                iDarts = iDarts + 1
                iValue = (Cells(Target.Row, 5) * (Target.Column - 5))
                iSum = iSum + iValue
                Cells(iDarts + 2, 9) = iValue
        End Select
    Case 23 To 25
        Select Case Target.Column
            Case 2, 3, 4
                iDarts = iDarts + 1
                iValue = Cells(Target.Row, 5)
                iSum = iSum + iValue
                Cells(iDarts + 2, 1) = iValue
            Case 6, 7, 8
                iDarts = iDarts + 1
                iValue = Cells(Target.Row, 5)
                iSum = iSum + iValue
                Cells(iDarts + 2, 9) = iValue
        End Select
End Select

'Abrechnung nach drei Darts, Reset der Public Integers
If iDarts = 3 Then
    MsgBox iSum
    'HIER GEHÖRT DER CODE ZUM AUFRUF DEINES SCHALLEREGNISSES HIN
    Select Case Target.Column
        Case 2, 3, 4
            rngLeft.Clear
            Cells(1, 1) = Cells(1, 1) + iSum
        Case 6, 7, 8
            rngRight.Clear
            Cells(1, 9) = Cells(1, 9) + iSum
    End Select
    iDarts = 0
    iSum = 0
End If

'Spielende
If Cells(1, 1) = Cells(1, 5) Or Cells(1, 9) = Cells(1, 5) Then
    rngLeft.Clear
    rngRight.Clear
    Select Case Target.Column
        Case 2, 3, 4
            MsgBox "Spieler A hat gewonnen!", , "Game over!"
        Case 6, 7, 8
            MsgBox "Spieler B hat gewonnen!", , "Game over!"
    End Select
End If

End Sub


Den Code kann man leicht noch so anpassen, dass Einträge immer nur bei einem Spieler möglich sind und durch Zellfarben der jeweilige Spieler markiert wird. Neben den Varianten 501 / 301 lässt sich auch z.B. Cricket realisieren. Das mache ich aber dann zuhause

Grüße

0 Punkte
Beantwortet von vbastler Mitglied (316 Punkte)

Und schon gibt es eine Version inkl. Cricket

Viel Spaß damit!

0 Punkte
Beantwortet von addeguddi Experte (2.6k Punkte)

Vielen Dank für deine Antwort.

Leider kann ich dies für meine Tabelle nicht nutzen. Habe dir einmal eine Dartliste mit nur 2 Spieler hochgeladen, schau dir diese mal und teste sie einmal. nur in den Zahlenfelder 1 bis 0 per Doppelklick klicken. kannst mir wenn du willst ein Feedback geben.   .https://supportnet.de/forum/?qa=blob&qa_blobid=5977962597674026649

Gruß Adde

0 Punkte
Beantwortet von vbastler Mitglied (316 Punkte)

Moin Adde,

Leider kann ich dies für meine Tabelle nicht nutzen. 

Kannst Du es nachvollziehen, wenn ich mit diesem Satz nichts anfangen kann? Ich mit Deinem nämlich nicht. Kannst du bitte konkretisieren, was nicht nutzbar ist? Dann schaue ich mir auch gerne Deine Tabelle an. Du erwähnst 0 bis 10. Welche Variante von Darts wird damit abgebildet?

Grüße

0 Punkte
Beantwortet von addeguddi Experte (2.6k Punkte)
Bearbeitet von addeguddi
Guten Morgen vbastler,

Entschuldigung, habe mich vielleicht nicht richtig ausgedrückt.  Habe die Liste getestet, funktioniert auch, aber leider passt dies nicht in mein VBA. da meine Liste die sehr umfangreich ist, die Punkte angezeigt werden, die Spieler automatisch nach 3 Würfe wechseln und dann kommt die Ansage der geworfene Punktzahl. Bei deinem Vorschlag fragt er mich ab ob es OK ist nach dem 3ten Wurf muss in meiner Liste nicht escheinen. Ich möchte nur gerne, dass nicht nach jedem Wurf die Ansage kommt sondern als Gesamtsumme angesagt wird.
Die1 bis 0 bedeutet, das die in Zelle A4 beginnend mit 1 B4 2 C4 3 bis Zelle F15 ein X für 0 steht die Zahlen stehen wobei in Zelle F15 ein X für 0 steht. Die Zahlen sind von 1 bis 60 wie im Dart verlangt wird
Nochmal es tut mir leid, deine Tabelle kann man benutzen.

Gruß Adde
0 Punkte
Beantwortet von vbastler Mitglied (316 Punkte)

Moin Adde,

ich vermute mal, du hast in Deinem letzten Satz ein nicht vergessen ...wink  Macht aber nichts, war ja nur ein Vorschlag.

Ich glaube aus Deinen Ausführungen zu erkennen, dass Du Dich nicht das erste Mal mit VBA beschäftigst. Deshalb hier noch Versuch Dir einen Lösungsansatz zu zeigen, den Du selbst einbauen kannst. Ich kenne Deine Code-Struktur nicht, deshalb hier ein Vorschlag, der in Worksheets, USF oder auch Allg. Modulen funktionieren sollte:

Definiere eine Public Variable bDarts As Byte und zähle diese bei jedem Eintrag in Deiner Tabelle um 1 hoch. Sobald der Wert 3 erreicht ist, lässt Du die Ansage plärren und setzt bDarts wieder auf Null. Das könnte Code-technisch ungefähr so aussehen:

If bDarts = 3 Then
    MachKrach
    bDarts = 0
End If

Die Variable Public zu setzen hat hier den Vorteil, dass Du sie auch über den Rahmen von Subs hinaus nutzen kannst und sie nicht am Ende jeder Sub wieder geleert wird. Ähnlich habe ich das auch in meiner VBAstelei realisiert.

Alternativ könntest du auch ein Public Boolean nutzen. Ist aber aufwändiger.

Viel Spaß beim Spießchen-Schmeißen!

0 Punkte
Beantwortet von addeguddi Experte (2.6k Punkte)
Hallo vbastler,

nochmals vielen Dank für deine Mühe.

Wünsche dir noch eine schöne Woche.

Gruß Adde
...