Datenüberprüfung erweiteren

Forumthread: Datenüberprüfung erweiteren

15.03.2021 17:08:58

UweD

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

2
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

AW: Datenüberprüfung erweiteren

16.03.2021 08:31:36

ChrisL
AW: Datenüberprüfung erweiteren

16.03.2021 11:54:04

UweD

AW: Datenüberprüfung erweiteren

16.03.2021 08:31:36

ChrisL

Hi Uwe
Modul von Tabelle Eingabe:

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

cu
Chris

AW: Datenüberprüfung erweiteren

16.03.2021 11:54:04

UweD

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)

Forumthread: Datenüberprüfung erweiteren

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

Forumthreads zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

2
Beiträge zum Forumthread

Beiträge zu diesem Forumthread