Einfaches Darts-Sheet

d'r Bastler · #61

Moin Adde,

Deine Beiträge und Anhänge kommen an. Leider behauptet diese Version der Forensoftware fälschlicherweise, dass noch nie ein Anhang heruntergeladen wurde. Das muss ich auf meine Kappe nehmen, weil ich das entsprechende Update immer noch nicht gewagt habe. Das hat also sicher nichts mit Deinen Posts zu tun.

Ich bin sicher, dass Erwin (Wisi82) Deine Arbeiten hier verfolgt und auch zeitnah (so es ihm möglich ist) beantworten wird. Kann aber sein, dass er vor lauter Spießchen schmeißen (macht er nämlich sehr gerne) im Moment kaum Zeit hat

Schönen Abend noch! und Grüße!

Adde · #62

Guten Morgen
und danke für deine Rückmeldung.
Gruß Adde

d'r Bastler · #63

Moin Adde,

Beverlys/Karins Vorschlag Doppelklicks zu nehmen hat den Grund, dass Einzelklicks nur über den Selection_Change-Event abgefangen werden können und damit auch versehentliche Wechsel einer Zelle den erwähnten Zähler hochzählen würden. Das wieder zurückzusetzen wäre umständlich und fehleranfällig.

Die Alternative wären einfache Rechtsklicks. Die können gezielt abgefangen werden und dann könnte man einen Zähler im VBA nutzen, der nicht sichtbar sein muss.

So funktionert's: Du markiert die drei Zellen in Deinem Sheet und trägst in das Namensfeld "Aufnahme" ein. Damit hast einen Namensbereich definiert. Dann gehört folgender Code in das Sheet

Code: Alles auswählen

Option Explicit
Public bClicks As Byte

Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean)
Cancel = True
If Not Intersect(Target, Range("Aufnahme")) Is Nothing Then
    bClicks = bClicks + 1
    If bClicks >= 3 Then
        bClicks = 0
        MsgBox "Hier Dein Code"
    End If
End If

End Sub

in den Du dann Deine weitere Verarbeitung einsetzen kannst.

Grüße

Adde · #64

Danke für deine Antwort d'r Bastlser,
aber ich stehe etwas auf dem Schlauch. Bei diesem Dart geht nur der LINKSKLICK soll jetzt RECHTSKLICK eingesetzt werden oder soll ich das in mein Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean) einfügen? was müsste ich in Msgbox eintragen !! "Aufnahme bestätigen"?

Vielleicht kannst du mir nochmal bitte helfen.

Gruß Adde

d'r Bastler · #65

Moin Adde,

beschreibe doch bitte mal, wie Du jetzt Deinen LinksClick abfängst. Per ClickEvent auf eine Grafik ...? Oder Du stellst einfach den Code der Tabelle hier als Code-Snippet ein. Mir fehlt im Moment die Zeit Deine ganze Arbeitsmappe durchzusehen, helfen will ich trotzdem gerne.

Eigentlich üsste das schon funktionieren: Den Code "Spielerwechsel, usw." setzt Du als Ersatz für meine Zeile Msgbox ein. Dann tut der Rechtsklick das, was der Einzelklick vorher getan hat.

Schöne Grüße

Adde · #66

Vielen lieben Dank für deine Antwort D 'r' Bastler,
ja ich bin noch nicht so firm im VBA muss noch viel lernen, aber ich weiß nicht ob ich das schaffe bin schon ziemlich alt.
wenn du irgendwann Zeit hast kannst du dir das anschauen.
Gruß Adde

Adde · #67

Nochmal ich, habe schon etwas erstellt ,
da werden die Spieler automatisch gewechselt aber nur bei bei geraden Spieler klappt es und bei ungeraden fängt er mit dem 2 Wurf an und ich muss dann bestätigen.
ich weiß leider nicht mehr welche da ich geladen habe. Wenn du Zeit das nicht die Datei ist die automatisch mit dem Fehler wechselt wüde ich die über das andere Forum hoch laden.

Gruß Adde

d'r Bastler · #68

Auch nochmal ich

Einfach den Code der Tabelle hier als Snippet einstellen: Rechte Maustaste auf den Tabellennamen > Code anzeigen > Strg+A, dann Strg+C. Hier eine Antwort erstellen, das kleine schwarze Symbol </> auswählen und den Code zwischen den Tags [] ... [/] mit Strg+V einfügen. Gerne Kommentar und Gruß-los. Schon kann ich mir das anschauen.

Wenn Du das im anderen Forum einstellen willst, mach das ruhig. Pass aber auf, dass Dich dann nicht jemand wegen CrossPosting anmeckert.

Schönen Abend noch!

Adde · #69

Hallo D' r' Bastler,
hoffe ich habe es richtig gemacht!
Gruß Adde

Code: Alles auswählen

Option Explicit
Dim Feld As Single
Dim Typ As Single
Public Dart As Long
Public aktiver_Spieler
Public Spielziel As Long

Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean)
ActiveSheet.Unprotect
If Not Intersect(Target, Range("N15")) Is Nothing Then
        Cancel = True
        Range("N15") = Range("N15").Value + 1
End If
If Not Intersect(Target, Range("N16")) Is Nothing Then
        Cancel = True
        Range("N16") = Range("N16").Value + 1
End If
If Not Intersect(Target, Range("N17")) Is Nothing Then
        Cancel = True
        Range("N17") = Range("N17").Value + 1
End If
If Not Intersect(Target, Range("N18")) Is Nothing Then
        Cancel = True
        Range("N18") = Range("N18").Value + 1
End If
If Not Intersect(Target, Range("N19")) Is Nothing Then
        Cancel = True
        Range("N19") = Range("N19").Value + 1
End If
If Not Intersect(Target, Range("N20")) Is Nothing Then
        Cancel = True
        Range("N20") = Range("N20").Value + 1
End If
If Not Intersect(Target, Range("N4")) Is Nothing Then
        Cancel = True
        Range("N4") = Range("N4").Value + 1
End If
Cancel = True
If Not Intersect(Target, Range("Aufnahme")) Is Nothing Then
    bClicks = bClicks + 1
    If bClicks >= 3 Then
        bClicks = 0
        MsgBox "Hier Dein Code"
    End If
End If
End Sub
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)

If Not Intersect(Target, Range("n4")) Is Nothing Then
        Cancel = True
        Range("N4") = 1
End If
End Sub
Sub Aufnahme_bestaetigen()
    Call Spieler_wechseln
    Range("F3:H3").ClearContents
    Dart = 0
    Call Darts_ausblenden
End Sub
Sub Aufnahme_reset()
    ' Prüfen, welcher Wurf zurückgesetzt werden soll
    If Dart = 1 Then
        Range("F3").ClearContents
        Dart = 0  ' Bereit für den ersten Wurf
    ElseIf Dart = 2 Then
        Range("G3").ClearContents
        Dart = 1  ' Bereit für den zweiten Wurf
    ElseIf Dart = 3 Then
        Range("H3").ClearContents
        Dart = 2  ' Bereit für den dritten Wurf
    End If
    
    Call Darts_ausblenden
End Sub

Sub Spiel_reset()
    Spielziel = Range("M3")
    Range("F3:H3").ClearContents
    aktiver_Spieler = 6
    Call Spieler_wechseln
    Range("P6") = Spielziel
    Range("P7") = Spielziel
    Range("P8") = Spielziel
    Range("P9") = Spielziel
    Range("P10") = Spielziel
    Range("P11") = Spielziel
    Range("n6") = Spielziel
    Range("n7") = Spielziel
    Range("n8") = Spielziel
    Range("n9") = Spielziel
    Range("n10") = Spielziel
    Range("n11") = Spielziel
    Range("N6:N11") = Spielziel
    Dart = 0
    
    Call Darts_ausblenden
End Sub

Sub Spieler_wechseln()
    Dim AufnahmeErgebnis As Long
    Dim aktiver_Spieler As Long
    Dim Spielende As Boolean
    Dim Zelle As Range

    ' Initialisiere die Variable aktiver_Spieler, falls noch nicht geschehen
    If IsEmpty(Range("T6").Value) Then
        aktiver_Spieler = 1
    Else
        aktiver_Spieler = Range("T6").Value
    End If

    ' Berechne das AufnahmeErgebnis aus den Zellen F3, G3 und H3
    AufnahmeErgebnis = Range("F3").Value + Range("G3").Value + Range("H3").Value
    
    ' Setze die Farbe aller Spieler zurück
    Range("M6:M11").Interior.Color = 15921906
    
    ' Aktualisiere die Punkte des aktiven Spielers
    Range("P6:P11").Cells(aktiver_Spieler).Value = Range("P6:P11").Cells(aktiver_Spieler).Value - AufnahmeErgebnis
    
    ' Aktualisiere die Punktzahl in I3 für den aktiven Spieler
    Range("I3").Value = Range("P6:P11").Cells(aktiver_Spieler).Value
    
    ' Ansage der Punktzahl für den aktiven Spieler
    Application.Speech.Speak Range("AB2").Value & " hat " & Range("I4").Value & " Punkte."
    
    ' Überprüfe, ob irgendein Spieler das Spiel beendet hat
    Spielende = False
    For Each Zelle In Range("P6:P11")
        If Zelle.Value = 0 Then
            Spielende = True
            Exit For
        End If
    Next Zelle
    
    If Spielende Then
        Application.Speech.Speak "ChecK Out!"
        Exit Sub
    End If
    
    ' Wechsle zum nächsten Spieler
    aktiver_Spieler = aktiver_Spieler + 1
    If aktiver_Spieler > Range("M22").Value Then aktiver_Spieler = 1
    
    ' Setze die Farbe des aktiven Spielers
    Range("M6:M11").Cells(aktiver_Spieler).Interior.Color = 5287936
    
    ' Zeige die Nummer des aktiven Spielers in Zelle T6 an
    Range("T6").Value = aktiver_Spieler
    
    ' Ansage des nächsten Spielers
    Application.Speech.Speak Range("AB2").Value & " ist an der Reihe."
End Sub


Sub Darts_ausblenden()
    Select Case Dart
        Case 0
            Shapes("Dart1").Visible = True
            Shapes("Dart2").Visible = True
            Shapes("Dart3").Visible = True
        Case 1
            Shapes("Dart1").Visible = False
            Shapes("Dart2").Visible = True
            Shapes("Dart3").Visible = True
        Case 2
            Shapes("Dart1").Visible = False
            Shapes("Dart2").Visible = False
            Shapes("Dart3").Visible = True
        Case 3
            Shapes("Dart1").Visible = False
            Shapes("Dart2").Visible = False
            Shapes("Dart3").Visible = False
    End Select
End Sub
Sub Punkte_verrechnen(Feld As Single, Typ As Single)
    Dim Ergebnis As Long
    Dim aktiver_Spieler As Integer
    Ergebnis = Feld * Typ
    
    ' Stelle sicher, dass die Variable aktiver_Spieler korrekt gesetzt ist
    ' Beispiel: aktiver_Spieler = 1

    Select Case Dart
        Case 3
            MsgBox "Es wurden bereits drei Pfeile geworfen, zuerst Aufnahme bestätigen oder korrigieren"
            Exit Sub
        Case 0
            Range("F3") = Ergebnis
        Case 1
            Range("G3") = Ergebnis
        Case 2
            Range("H3") = Ergebnis
    End Select
    ' MsgBox "Es wurden " & Ergebnis & " Punkte erzielt"
    Dart = Dart + 1
    Call Darts_ausblenden

    ' Aktualisiere die Werte in den Zellen U6 bis U11 basierend auf dem aktiven Spieler
    ' Die folgende Zeile weist den Wert aus O6 bis O11 der entsprechenden Zelle in U6 bis U11 zu
    ' Stelle sicher, dass die Formeln in den Zellen O6 bis O11 ausgewertet wurden
    Application.Calculate

    ' Zuweisung der Werte für jeden Spieler
    Range("V6").Value = Range("o6").Value ' Für Spieler 1
    Range("V7").Value = Range("o7").Value ' Für Spieler 2
    Range("V8").Value = Range("o8").Value ' Für Spieler 3
    Range("V9").Value = Range("o9").Value ' Für Spieler 4
    Range("U10").Value = Range("o10").Value ' Für Spieler 5
    Range("V11").Value = Range("o11").Value ' Für Spieler 6
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
    Dim NameRange As Range
    Set NameRange = Me.Range("AB2")
        If Not Me.ProtectContents Then
        ' Überprüfen, ob die geänderte Zelle innerhalb des Bereichs F3:H3 liegt
        If Not Intersect(Target, Me.Range("F3:H3")) Is Nothing Then
            ' Rufen Sie das Makro Aufnahme_bestaetigen auf, wenn alle Zellen Zahlen enthalten
            If Application.WorksheetFunction.CountA(Me.Range("F3:H3")) = 3 Then
                If Application.WorksheetFunction.Count(Me.Range("F3:H3")) = 3 Then
                    Aufnahme_bestaetigen
                End If
            End If
        End If
    End If

    ' Überprüfen, ob die Änderung in Zelle AB2 stattgefunden hat
    If Not Intersect(Target, NameRange) Is Nothing Then
        ' Die Spielernummer basierend auf dem Namen in AB2 ermitteln
        Dim SpielerNummer As Integer
        SpielerNummer = Evaluate("WENN('Eingabe grafisch'!AB2=""ADDE"";1;WENN('Eingabe grafisch'!AB2=""Astrid"";2;WENN('Eingabe grafisch'!AB2=""Astrid"";Dieter M;WENN('Eingabe grafisch'!AB2=""Marco"";4;WENN('Eingabe grafisch'!AB2=""Thomas"";5;WENN('Eingabe grafisch'!AB2=""Carmen"";6;WENN('Eingabe grafisch'!AB2=""Iris"";7;WENN('Eingabe grafisch'!AB2=""Guddi"";8;WENN('Eingabe grafisch'!AB2=""?"";9;WENN('Eingabe grafisch'!AB2=""Jose"";10;WENN('Eingabe grafisch'!AB2=""Gerd"";11;WENN('Eingabe grafisch'!AB2=""Dieter G"";12;WENN('Eingabe grafisch'!AB2=""Rainer"";13;WENN('Eingabe grafisch'!AB2=""Manfred"";15;))") ' Formel fortsetzen
        ' Überprüfen, ob eine gültige Nummer gefunden wurde
        If SpielerNummer > 0 Then
            ' Den Namen des Bildes aus dem Tabellenblatt 'Bilder' holen
            Dim BildName As String
            BildName = Sheets("Bilder").Range("A" & SpielerNummer).Value

            ' Überprüfen, ob ein Bildname gefunden wurde
            If BildName <> "" Then
                ' Bild anzeigen basierend auf dem Namen
                ' Hier müssen Sie den Code anpassen, um das Bild aus dem Tabellenblatt 'Bilder' zu holen
                Dim Bild As Shape
                On Error Resume Next ' Falls kein Bild gefunden wird
                Set Bild = Sheets("Eingabe grafisch").Shapes(BildName)
                On Error GoTo 0 ' Fehlerbehandlung zurücksetzen

                If Not Bild Is Nothing Then
                    ' Bildposition und -größe anpassen
                    With Bild
                        .Top = Sheets("Eingabe grafisch").Range("E1").Top
                        .Left = Sheets("Eingabe grafisch").Range("E1").Left
                        .Width = Sheets("Eingabe grafisch").Range("E1").Width
                        .Height = Sheets("Eingabe grafisch").Range("E1").Height
                        .Visible = msoTrue
                    End With
                Else
                    MsgBox "Bild '" & BildName & "' nicht gefunden."
                End If
            Else
                MsgBox "Kein Bildname für den Wert gefunden."
            End If
        Else
            MsgBox "Bitte geben Sie einen gültigen Namen in Zelle AB2 ein."
        End If
    End If
    
End Sub

Sub Null_click()
    Feld = 0
    Typ = 1
    Call Punkte_verrechnen(Feld, Typ)
End Sub
Sub S1_click()
    Feld = 1
    Typ = 1
    Call Punkte_verrechnen(Feld, Typ)
End Sub
Sub D1_click()
    Feld = 1
    Typ = 2
    Call Punkte_verrechnen(Feld, Typ)
End Sub
Sub T1_click()
    Feld = 1
    Typ = 3
    Call Punkte_verrechnen(Feld, Typ)
End Sub
Sub S2_click()
    Feld = 2
    Typ = 1
    Call Punkte_verrechnen(Feld, Typ)
End Sub
Sub D2_click()
    Feld = 2
    Typ = 2
    Call Punkte_verrechnen(Feld, Typ)
End Sub
Sub T2_click()
    Feld = 2
    Typ = 3
    Call Punkte_verrechnen(Feld, Typ)
End Sub
Sub S3_click()
    Feld = 3
    Typ = 1
    Call Punkte_verrechnen(Feld, Typ)
End Sub
Sub D3_click()
    Feld = 3
    Typ = 2
    Call Punkte_verrechnen(Feld, Typ)
End Sub
Sub T3_click()
    Feld = 3
    Typ = 3
    Call Punkte_verrechnen(Feld, Typ)
End Sub
Sub S4_click()
    Feld = 4
    Typ = 1
    Call Punkte_verrechnen(Feld, Typ)
End Sub
Sub D4_click()
    Feld = 4
    Typ = 2
    Call Punkte_verrechnen(Feld, Typ)
End Sub
Sub T4_click()
    Feld = 4
    Typ = 3
    Call Punkte_verrechnen(Feld, Typ)
End Sub
Sub S5_click()
    Feld = 5
    Typ = 1
    Call Punkte_verrechnen(Feld, Typ)
End Sub
Sub D5_click()
    Feld = 5
    Typ = 2
    Call Punkte_verrechnen(Feld, Typ)
End Sub
Sub T5_click()
    Feld = 5
    Typ = 3
    Call Punkte_verrechnen(Feld, Typ)
End Sub
Sub S6_click()
    Feld = 6
    Typ = 1
    Call Punkte_verrechnen(Feld, Typ)
End Sub
Sub D6_click()
    Feld = 6
    Typ = 2
    Call Punkte_verrechnen(Feld, Typ)
End Sub
Sub T6_click()
    Feld = 6
    Typ = 3
    Call Punkte_verrechnen(Feld, Typ)
End Sub
Sub S7_click()
    Feld = 7
    Typ = 1
    Call Punkte_verrechnen(Feld, Typ)
End Sub
Sub D7_click()
    Feld = 7
    Typ = 2
    Call Punkte_verrechnen(Feld, Typ)
End Sub
Sub T7_click()
    Feld = 7
    Typ = 3
    Call Punkte_verrechnen(Feld, Typ)
End Sub
Sub S8_click()
    Feld = 8
    Typ = 1
    Call Punkte_verrechnen(Feld, Typ)
End Sub
Sub D8_click()
    Feld = 8
    Typ = 2
    Call Punkte_verrechnen(Feld, Typ)
End Sub
Sub T8_click()
    Feld = 8
    Typ = 3
    Call Punkte_verrechnen(Feld, Typ)
End Sub
Sub S9_click()
    Feld = 9
    Typ = 1
    Call Punkte_verrechnen(Feld, Typ)
End Sub
Sub D9_click()
    Feld = 9
    Typ = 2
    Call Punkte_verrechnen(Feld, Typ)
End Sub
Sub T9_click()
    Feld = 9
    Typ = 3
    Call Punkte_verrechnen(Feld, Typ)
End Sub
Sub S10_click()
    Feld = 10
    Typ = 1
    Call Punkte_verrechnen(Feld, Typ)
End Sub
Sub D10_click()
    Feld = 10
    Typ = 2
    Call Punkte_verrechnen(Feld, Typ)
End Sub
Sub T10_click()
    Feld = 10
    Typ = 3
    Call Punkte_verrechnen(Feld, Typ)
End Sub
Sub S11_click()
    Feld = 11
    Typ = 1
    Call Punkte_verrechnen(Feld, Typ)
End Sub
Sub D11_click()
    Feld = 11
    Typ = 2
    Call Punkte_verrechnen(Feld, Typ)
End Sub
Sub T11_click()
    Feld = 11
    Typ = 3
    Call Punkte_verrechnen(Feld, Typ)
End Sub
Sub S12_click()
    Feld = 12
    Typ = 1
    Call Punkte_verrechnen(Feld, Typ)
End Sub
Sub D12_click()
    Feld = 12
    Typ = 2
    Call Punkte_verrechnen(Feld, Typ)
End Sub
Sub T12_click()
    Feld = 12
    Typ = 3
    Call Punkte_verrechnen(Feld, Typ)
End Sub
Sub S13_click()
    Feld = 13
    Typ = 1
    Call Punkte_verrechnen(Feld, Typ)
End Sub
Sub D13_click()
    Feld = 13
    Typ = 2
    Call Punkte_verrechnen(Feld, Typ)
End Sub
Sub T13_click()
    Feld = 13
    Typ = 3
    Call Punkte_verrechnen(Feld, Typ)
End Sub
Sub S14_click()
    Feld = 14
    Typ = 1
    Call Punkte_verrechnen(Feld, Typ)
End Sub
Sub D14_click()
    Feld = 14
    Typ = 2
    Call Punkte_verrechnen(Feld, Typ)
End Sub
Sub T14_click()
    Feld = 14
    Typ = 3
    Call Punkte_verrechnen(Feld, Typ)
End Sub
Sub S15_click()
    Feld = 15
    Typ = 1
    Call Punkte_verrechnen(Feld, Typ)
End Sub
Sub D15_click()
    Feld = 15
    Typ = 2
    Call Punkte_verrechnen(Feld, Typ)
End Sub
Sub T15_click()
    Feld = 15
    Typ = 3
    Call Punkte_verrechnen(Feld, Typ)
End Sub
Sub S16_click()
    Feld = 16
    Typ = 1
    Call Punkte_verrechnen(Feld, Typ)
End Sub
Sub D16_click()
    Feld = 16
    Typ = 2
    Call Punkte_verrechnen(Feld, Typ)
End Sub
Sub T16_click()
    Feld = 16
    Typ = 3
    Call Punkte_verrechnen(Feld, Typ)
End Sub
Sub S17_click()
    Feld = 17
    Typ = 1
    Call Punkte_verrechnen(Feld, Typ)
End Sub
Sub d17_click()
    Feld = 17
    Typ = 2
    Call Punkte_verrechnen(Feld, Typ)
End Sub
Sub T17_click()
    Feld = 17
    Typ = 3
    Call Punkte_verrechnen(Feld, Typ)
End Sub
Sub S18_click()
    Feld = 18
    Typ = 1
    Call Punkte_verrechnen(Feld, Typ)
End Sub
Sub D18_click()
    Feld = 18
    Typ = 2
    Call Punkte_verrechnen(Feld, Typ)
End Sub
Sub T18_click()
    Feld = 18
    Typ = 3
    Call Punkte_verrechnen(Feld, Typ)
End Sub
Sub S19_click()
    Feld = 19
    Typ = 1
    Call Punkte_verrechnen(Feld, Typ)
End Sub
Sub D19_click()
    Feld = 19
    Typ = 2
    Call Punkte_verrechnen(Feld, Typ)
End Sub
Sub T19_click()
    Feld = 19
    Typ = 3
    Call Punkte_verrechnen(Feld, Typ)
End Sub
Sub S20_click()
    Feld = 20
    Typ = 1
    Call Punkte_verrechnen(Feld, Typ)
End Sub
Sub D20_click()
    Feld = 20
    Typ = 2
    Call Punkte_verrechnen(Feld, Typ)
End Sub
Sub T20_click()
    Feld = 20
    Typ = 3
    Call Punkte_verrechnen(Feld, Typ)
End Sub
Sub SB_click()
    Feld = 25
    Typ = 1
    Call Punkte_verrechnen(Feld, Typ)
End Sub
Sub DB_click()
    Feld = 25
    Typ = 2
    Call Punkte_verrechnen(Feld, Typ)
End Sub

d'r Bastler · #70

Moin Adde!

damit kann ich doch schon was anfangen! Prächtig! Ich melde mich später am Tag mit (hoffentlich

) hilfreicher Antwort.

Grüße

Einfaches Darts-Sheet

Re: Einfaches Darts-Sheet

Re: Einfaches Darts-Sheet

Re: Einfaches Darts-Sheet

Re: Einfaches Darts-Sheet

Re: Einfaches Darts-Sheet

Re: Einfaches Darts-Sheet

Re: Einfaches Darts-Sheet

Re: Einfaches Darts-Sheet

Re: Einfaches Darts-Sheet

Re: Einfaches Darts-Sheet

Wer ist online?