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

Informationen und Beispiele zu den hier genannten Dialog-Elementen:
MsgBox
Bild

Betrifft: Zelle mit Doppelklick befüllen, aber nur 1 von 3
von: Hel
Geschrieben am: 03.12.2015 14:21:53

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

Bild

Betrifft: zelle mit Doppelklick befüllen, aber nur 1 von 3
von: Rudi Maintaire
Geschrieben am: 03.12.2015 16:12:25
Hallo,

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
Gruß
Rudi

Bild

Betrifft: Danke!
von: Hel
Geschrieben am: 03.12.2015 17:54:01
Poah vielen Dank, das funktioniert genial!!
eine Frage hätte ich noch, ich habe deinen Code so umgeschrieben, dass er in der Zeile auf 3 Felder nebeneinander für eine Frage super Funktioniert, aber jetzt habe ich 102 Zeilen mit Fragen, muss ich den Code jetzt für jede Zeile umändern oder gibt es eine Möglichkeit trotz der Zeilenbeschränkung (nur 1 Element von 3 soll gehen) dass auch vereinfacht auf ein Feld in der Größe von A1 bis Z3 anzuwenden?
Vielen Dank für Deinen Code!

Bild

Betrifft: Danke, aber jetzt hab ich noch ein kleines Problem
von: Hel
Geschrieben am: 03.12.2015 18:21:06
Vielen Dank für deinen Code der Funktioniert super!
Ich habe ihn so angepasst dass er in einer Zeile einer Frage nun die 3 Antwortmöglichkeiten genau umfasst, mit einer bedingten Formatierung wird das ganze jetzt auch farblich super dargestellt, aber mein Problem ist jetzt, dass ich 102 Fragen habe und den Code 101 x anpassen müsste, gibt's es da auch eine Möglichkeit, dass es pro Zeile nur 1 Antwort umfasst aber dass es gleich über den Block zb A1 - C10 jeweils nur die Zeile umfasst oder muss ich jetzt 101 mal den Code kopieren und pro Zeile anpassen??
Danke jedenfalls für Deine tolle Hilfe!
LG

Bild

Betrifft: AW: Danke, aber jetzt hab ich noch ein kleines Problem
von: Sepp
Geschrieben am: 03.12.2015 21:14:28
Hallo Helmut,
probier mal so.

' **********************************************************************
' 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

Gruß Sepp


Bild

Betrifft: Korrektur!
von: Sepp
Geschrieben am: 03.12.2015 21:22:03

' **********************************************************************
' 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

Gruß Sepp


Bild

Betrifft: AW: Danke, aber jetzt hab ich noch ein kleines Problem
von: Hel
Geschrieben am: 04.12.2015 07:59:00
Vielen, vielen DANK, ich habe den Code an meine Zwecke angepasst und alles funktioniert wunderbar!
Vielen Dank nochmal, schönes Wochenende!
LG
Helmut

 Bild

Beiträge aus den Excel-Beispielen zum Thema "Zelle mit Doppelklick befüllen, aber nur 1 von 3 "