Mehrere Worksheet_BeforeDoubleClick in einem Tabelle

Hallo liebes Forum,
folgendes Problem schaffe ich persönliche nicht zu lösen.
Der folgende Code muss so modifiziert werden, dass er für die folgenden Bereiche ebenso funktioniert. Leider habe ich keine Idee dafür.
Kurzer Hintergrund: Das Anklicken der Zellen soll als Antwort für einen Fragebogen ausgewertet werden. Dabei soll in dem jeweiligen Bereich immer nur eine Antwort möglich sein.
Ich hoffe jemand kann mich bei der Lösung unterstützen.
Vielen Dank.
Gruß Manu
Bereiche für RaBereiche: F17:J17 , F24:J24 , F31:J31 , F38:J38 , F45:J45 , F52:J52 , F59:J59 , F66:J66 , F73:J73 , F80:J80 , F87:J87 , F94:J94
jeweils dazu zugeordnetes Prüfkriterium steht in: B14, B21, B28, B35, B42 usw.

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean) Dim RaBereich As Range ' Variable Zelle Dim Anzahl As Integer Set RaBereich = Range("F17:J17") ' Bereich der Wirksamkeit Anzahl = Range("B14") If Anzahl = 0 Then If Not Intersect(Target, RaBereich) Is Nothing Then Application.EnableEvents = False ' Reaktion auf Zellveränderung ausschalten Cancel = True ' damit Cursor nicht in Zelle nach _ Doppelklick If Target.Value = "r" Then Target.Value = "" ' falls Zellinhalt X, Zelle leeren Else Target.Value = "r" ' falls Zelle leer, X eintragen End If Application.EnableEvents = True ' Reaktion auf Zellveränderunge einschalten Set RaBereich = Nothing ' Variable leeren End If Else Range("F17:J17").ClearContents If Not Intersect(Target, RaBereich) Is Nothing Then Application.EnableEvents = False ' Reaktion auf Zellveränderung ausschalten Cancel = True ' damit Cursor nicht in Zelle nach _ Doppelklick If Target.Value = "r" Then Target.Value = "" ' falls Zellinhalt X, Zelle leeren Else Target.Value = "r" ' falls Zelle leer, X eintragen End If Application.EnableEvents = True ' Reaktion auf Zellveränderunge einschalten Set RaBereich = Nothing ' Variable leeren End If End If End Sub

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Hallo Manu,
so?

Option Explicit

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)

    Dim RaBereich As Range ' Variable Zelle

    Set RaBereich = Range("F17:J17,F24:J24,F31:J31,F38:J38,F45:J45,F52:J52," & _
        "F59:J59,F66:J66,F73:J73,F80:J80,F87:J87,F94:J94") ' Bereich der Wirksamkeit

    If Range("B14").Value <> 0 Then Call RaBereich.ClearContents

    If Not Intersect(Target, RaBereich) Is Nothing Then

        Application.EnableEvents = False ' Reaktion auf Zellveränderung ausschalten

        Cancel = True ' damit Cursor nicht in Zelle nach Doppelklick

        If Target.Value = "r" Then
            Target.Value = Empty ' falls Zellinhalt X, Zelle leeren
        Else
            Target.Value = "r" ' falls Zelle leer, X eintragen
        End If

        Application.EnableEvents = True ' Reaktion auf Zellveränderunge einschalten

    End If

    Set RaBereich = Nothing ' Variable leeren

End Sub

Gruß
Nepumuk

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean) Dim tmp On Error GoTo ERREXIT Application.EnableEvents = False tmp = Target Select Case Target.Column Case 6 To 10 'F:J Select Case Target.Row Case 17, 24, 31, 38, 45, 52, 59, 66, 73, 80, 87, 94 Cancel = True Cells(Target.Row, 6).Resize(, 5).ClearContents If tmp = "" Then Target = "r" End Select End Select ERREXIT: Application.EnableEvents = True End Sub

Beliebteste Forumthreads (12 Monate)

Mehrere Worksheet_BeforeDoubleClick in einem Tabelle

3
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

261 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Mehrere Worksheet_BeforeDoubleClick in einem Tabelle

3 Beiträge zum Forumthread Beiträge zu diesem Forumthread

261 Forumthreads zu ähnlichen Themen

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

3
Beiträge zum Forumthread

Beiträge zu diesem Forumthread