Zelle farblich markieren nach dem dritten Doppelklick

Question

Hallo und einen schönen Tag

versuche folgendes. In meiner Tabelle steht in Zelle E1 die Zuordnung was wir spielen möchten. Die Auswahl erfolgt über Doppelklick. Danach soll nach jedem dritten Doppelklick folgendes geschehen. Spieler 1 steht in Zelle B1 Spieler 2 in Zelle F1. Spieler 1 beginnt das Spiel und jetzt soll nach dem dritten Doppelklick soll die Zelle für Spieler 2 farblich markiert werden, danach ist Spieler 2 an der Reihe. Nun soll nach dem dritten Doppelklick die Zelle für Spieler 1 farblich markiert werden Usw. Habe ein Modul erstellt doch dies funktioniert leider nicht. Vielleicht kann mir jemand eine Lösung zukommen lassen. 

Das ist das Modul:

Dim spielerwechsel As Integer

' Diese Prozedur erhöht den spielerwechsel-Zähler und markiert die Zellen farblich
Public Sub DoppelklickHandler()
    ' Erhöhe den Zähler nur, wenn der Doppelklick im Spielbereich erfolgt
    spielerwechsel = spielerwechsel + 1
    
    ' Spielerwechsel nach jedem dritten Doppelklick
    If spielerwechsel Mod 3 = 0 Then
        ' Spieler 2 ist an der Reihe
        With ThisWorkbook.Sheets("Darts II").Range("f1")
            .Interior.Color = vbYellow ' Markiere Zelle F1 gelb
            .Font.Bold = True
        End With
        With ThisWorkbook.Sheets("Darts II").Range("B1")
            .Interior.Color = xlNone ' Entferne Markierung von Zelle B1
            .Font.Bold = False
        End With
    Else
        ' Spieler 1 ist an der Reihe
        With ThisWorkbook.Sheets("Darts II").Range("b1")
            .Interior.Color = vbYellow ' Markiere Zelle B1 gelb
            .Font.Bold = True
        End With
        With ThisWorkbook.Sheets("Darts II").Range("F1")
            .Interior.Color = xlNone ' Entferne Markierung von Zelle F1
            .Font.Bold = False
        End With
    End If
End Sub

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
    ' Prüfen, ob der Doppelklick in einem bestimmten Zellbereich erfolgt ist
    If Not Intersect(Target, Me.Range("B3:D15,F3:F15")) Is Nothing Then
        ' Aufruf der DoppelklickHandler-Prozedur
        DoppelklickHandler
        ' Verhindern, dass die Standard-Doppelklick-Aktion ausgeführt wird
        Cancel = True
    End If
End Sub

In meiner Arbeitsmappe habe ich noch ein VBA mit Doppelklick ich weiß nicht ob es daran liegt:

Gruß Adde

Answer 1

Hi Adde,

wenn es noch ein DoppelKlick-Ereignis gibt, dann musst du beide zusammenführen im Codemodul des Tabellenblattes - nach diesem Prinzip:

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
    ' Prüfen, ob der Doppelklick in einem bestimmten Zellbereich erfolgt ist
    If Not Intersect(Target, Me.Range("B3:D15,F3:F15")) Is Nothing Then
        ' Aufruf der DoppelklickHandler-Prozedur
        DoppelklickHandler
        ' Verhindern, dass die Standard-Doppelklick-Aktion ausgeführt wird
        Cancel = True
    ' prüfen ob der Doppelklick im anderen Zellbereich liegt
    ElseIf Not Intersect(Target, Range("A1:A10")) Is Nothing Then '<== Zellbereich anpassen!!!
        ' hier der Code für den anderen Zellbereich

        ' Verhindern, dass die Standard-Doppelklick-Aktion ausgeführt wird
        Cancel = True
    End If
End Sub

Deine Sub DoppelklickHandler()  kann im Standardmodul stehen bleiben.

Bis später, Karin

Answer 2

Hallo Karin vielen Dank für deine Antwort

Habe es umgesetzt leider klapptes nicht.

Müsste ich hier etwas ergänzen? 

   ElseIf Not Intersect(Target, Range("A1:A10")) Is Nothing Then '<== Zellbereich anpassen!!!
        ' hier der Code für den anderen Zellbereich

Gruß Adde

Answer 3

Hi Adde,

da ich weder deinen Code noch den anderen Zellbereich kenne, in dem er gelten soll, kann ich meinen Code nur sehr allgemein halten - anstelle der Zeile

' hier der Code für den anderen Zellbereich

musst du natürlich deinen Code schreiben und anstelle des Zellbereichs "A1:A10" deinen Zellbereich, für den er gelten soll (steht auch im Kommentar so dahinter).

Bis später, Karin

Answer 4

Danke Karin

habe es umgesetzt und es funktioniert.

Gruß Adde