Datenüberprüfung erweiteren

Hallo
Ich habe in einem Bereich eine Datenüberprüfung festgelegt, wobei auf eine "inteligente Tabelle" per Indirekt zugegriffen wird.
- In dem Eingabebereich werden die Einträge im Dropdown angezeigt.
- ich habe extra keine Warnmeldung eingeschaltet, wenn was ungültiges eingegeben wird.
- Wenn nun ein Wert eingetragen wird, der NICHT erlaubt ist, soll ein popup starten, ob der Eintrag in der Datentabelle angehangen werden soll.
Das schwierige dabei: Je nach Spalte soll (aus der Überschrift) die richtige Quell-Tabelle werden.
Also bin ich im Eingabebereich Farbe, soll im Dropdownbereich Farbe ergänzt werden.
Wenn jemand schon mal sowas gemacht hat, muss ich nicht ewig probieren. Da wären Tipps sehr hilfreich
Danke im voraus.
LG Uwe
https://www.herber.de/bbs/user/144817.xlsx

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Private Sub Worksheet_Change(ByVal Target As Range) Dim intSpalte As Integer If Target.Column = 2 Or Target.Column = 4 Then If Target = "" Then Exit Sub With Worksheets("Dropdown") If Target.Column = 2 Then intSpalte = 4 Else intSpalte = 2 If WorksheetFunction.CountIf(.Columns(intSpalte), Target) = 0 Then If MsgBox("Kein Eintrag. Ergänzen?", vbYesNo) = vbYes Then .Cells(Rows.Count, intSpalte).End(xlUp).Offset(1, 0) = Target Else Application.Undo End If End If End With End If End Sub

Hallo Chris
Du hast mir den entsprechenden Anstoß gegeben. Besten Dank.
Angewendet auf meine Originaltabelle ist das hier daraus geworden.


Private Sub Worksheet_Change(ByVal Target As Range)
Dim TT, RNG As Range
Dim ZUe As Integer, Z1 As Integer
On Error GoTo Fehler
Const APPNAME = "Worksheet_Change"
ZUe = 6 'Überschrift
Z1 = 8  'Erste Zeile mit Daten
For Each TT In Target
If TT.Row > Z1 Then
On Error GoTo Ende ' wenn keine Überprüfung in Zelle, dann Fehler
If TT.Validation.Type = xlValidateList Then
On Error GoTo Fehler 'Rückstellung auf Normale Fehlerbehandlung
'Datenquelle aus der Überschrift zuordnen
Set RNG = TB13.Range(Cells(ZUe, TT.Column))
If WorksheetFunction.CountIf(RNG, TT) = 0 Then
'Eintrag noch nicht vorhanden
JaNein = MsgBox(TT & ": ist ein unbekannter Eintrag." & vbLf & vbLf & _
"Tabelle um diesen Eintag ergänzen?", vbYesNo)
If JaNein = vbYes Then
'Eintrag unten ergänzen
RNG.Offset(RNG.Rows.Count, 0).Resize(1, 1) = TT
Else
'bei nein, Falschen Eintrag wieder löschen
With Application
.EnableEvents = False
.Undo
.EnableEvents = True
End With
End If
End If
End If
End If
Next
'*** Fehlerbehandlung
Err.Clear
Fehler:
Application.EnableEvents = True
If Err.Number  0 Then MsgBox "Fehler in Sub """ & APPNAME & """" & vbCrLf _
& "Fehlernummer: " & Err.Number & vbLf & Err.Description: Err.Clear
Ende: 'Fehlerende wenn keine Datenüberprüfung in Zelle
End Sub

LG UweD

Beliebteste Forumthreads (12 Monate)

2 Beiträge zum Forumthread Beiträge zu diesem Forumthread

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

2
Beiträge zum Forumthread

Beiträge zu diesem Forumthread