Zelle mit Doppelklick befüllen, aber nur 1 von 3

Liebes Forum,
ich habe ein Problem mit VBA bei dem ich mich nicht so gut auskenne, das mich aber jetzt schon seit 4 Stunden beschäftigt.
Ich möchte ein Excelsheet zur Auswertung einer Umfrage nutzen, es gibt die Antwortmöglichkeiten "Ja", "Nein", "Nicht anwendbar", also 3 Auswahlfelder wobei nur jeweils 1 Auswahl befüllt sein darf und bei dem Versuch 2 Auswahlfelder auszufüllen eine Fehlermeldung kommen soll.
Zusätzlich möchte ich keine Eingabe in die Zellen machen, sondern durch Doppelklick einen Wert eintragen lassen, ersteres funktioniert mit diesem Code:

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
If Not Intersect(Target, Range("A1:A3")) Is Nothing Then
Cancel = True
If IsEmpty(Target) Then Target = "x" Else Target = ""
End If
End Sub

Der zweite Code wurde von mir auch in das Tabellen VBA eingetragen und soll eine automatische Doppelnennung verhindern und die Fehlermeldung ausgeben.

Private Sub Worksheet_Change(ByVal rngTarget As Range)
X = Application.WorksheetFunction.CountA(Range("A1:A3"))
If X >= 2 Then
MsgBox "X kann nur einmal eingegeben werden!", 48, "Hinweis"
Application.EnableEvents = False
Application.Undo
rngTarget.Select
Application.EnableEvents = True
End If
End Sub

Beide in Kombination hintereinander gesetzt funktionieren aber nicht, würde sich irgendwer bitte meiner erbarmen und die beiden Schnippsel so verbinden, dass sie funktionieren, ich habe gerade die Nerven weggeworfen und mein Chef rotiert bereits..
Vielen Dank und lieber Gruß
aus Österreich
Helmut

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean) If Not Intersect(Target, Range("A1:A3")) Is Nothing Then Application.EnableEvents = False Cancel = True If Target = "x" Then Target = "" ElseIf Target = "" Then If WorksheetFunction.CountIf(Range("A1:A3"), "x") = 0 Then Target = "x" End If End If End If Application.EnableEvents = True End Sub Private Sub Worksheet_Change(ByVal Target As Range) If Not Intersect(Target, Range("A1:A3")) Is Nothing Then Application.EnableEvents = False If WorksheetFunction.CountIf(Range("A1:A3"), "x") > 1 Then Target = "" End If End If Application.EnableEvents = True End Sub

' ********************************************************************** ' Modul: Tabelle1 Typ: Element der Mappe(Sheet, Workbook, ...) ' ********************************************************************** Option Explicit 'Bereichsadressen definieren Private Const cstrRange As String = "B2:D11,G2:I11,L2:N11,B15:D24,G15:I24,L15:N24" Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean) Dim rng As Range, rngInput As Range On Error GoTo Errorhandler Application.EnableEvents = False Set rngInput = Range(cstrRange) If Not Intersect(rngInput, Target) Is Nothing Then Cancel = True For Each rng In rngInput.Areas If Not Intersect(Target, rng) Is Nothing Then If Target = "" Then rng.Rows(Target.Row - rng(1, 1).Row + 1) = "" Target = "x" Else Target = "" End If End If Next End If Errorhandler: Application.EnableEvents = True Set rngInput = Nothing End Sub Private Sub Worksheet_Change(ByVal Target As Range) Dim rng As Range, rngInput As Range On Error GoTo Errorhandler Application.EnableEvents = False Set rngInput = Range(cstrRange) If Not Intersect(rngInput, Target) Is Nothing Then For Each rng In rngInput.Areas If Not Intersect(Target, rng) Is Nothing Then rng.Rows(Target.Row - rng(1, 1).Row + 1) = "" Target = "x" End If Next End If Errorhandler: Application.EnableEvents = True Set rngInput = Nothing End Sub

' ********************************************************************** ' Modul: Tabelle1 Typ: Element der Mappe(Sheet, Workbook, ...) ' ********************************************************************** Option Explicit 'Bereichsadressen definieren Private Const cstrRange As String = "B2:D11,G2:I11,L2:N11,B15:D24,G15:I24,L15:N24" Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean) Dim rng As Range, rngInput As Range On Error GoTo Errorhandler Application.EnableEvents = False Set rngInput = Range(cstrRange) If Not Intersect(rngInput, Target) Is Nothing Then Cancel = True For Each rng In rngInput.Areas If Not Intersect(Target, rng) Is Nothing Then If Target = "" Then rng.Rows(Target.Row - rng(1, 1).Row + 1) = "" Target = "x" Else Target = "" End If End If Next End If Errorhandler: Application.EnableEvents = True Set rngInput = Nothing End Sub Private Sub Worksheet_Change(ByVal Target As Range) Dim rng As Range, rngInput As Range On Error GoTo Errorhandler Application.EnableEvents = False Set rngInput = Range(cstrRange) If Not Intersect(rngInput, Target) Is Nothing Then For Each rng In rngInput.Areas If Not Intersect(Target, rng) Is Nothing Then If Target <> "" Then rng.Rows(Target.Row - rng(1, 1).Row + 1) = "" Target = "x" End If End If Next End If Errorhandler: Application.EnableEvents = True Set rngInput = Nothing End Sub

Beliebteste Forumthreads (12 Monate)

Zelle mit Doppelklick befüllen, aber nur 1 von 3

6
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

303 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Zelle mit Doppelklick befüllen, aber nur 1 von 3

6 Beiträge zum Forumthread Beiträge zu diesem Forumthread

303 Forumthreads zu ähnlichen Themen

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

6
Beiträge zum Forumthread

Beiträge zu diesem Forumthread