" Intelligente Gültigkeit " etwas erweitert
udo
könnt mir bitte einer von Euch bei einem Problemchen helfen, ich komm grad leider nich weiter :
Hab 2 Tabellenblätter .
Blatt 1 is der Eingabe Bereich,
Blatt 2 dient als Vorgabebereich für eine automatisierte Gültigkeit.
Blatt1:
( 3 Spalten - E,F,G - jeweils von Zeile 7-1000) dient zum Eingeben von TextWerten
Blatt2:
( 3 Spalten - F, H, J - von Zeile 7- 1000 ) dient als Vorgabebereich.
bei Eingabe soll also Spalte E(Blatt1) mit F(Blatt2) verglichen werden, F(Blatt1) mit H(Blatt2), und G(Blatt1) mit J(Blatt2 ).
- wenn jeweils neuer Eintrag in einer der drei Spalten erkannt wurde, soll dieser dann in die entsprechende Vorgabe Spalte auf Blatt2 dann eingetragen werden.
Folgendes Makro funktioniert auch schon ganz gut , wenn die Zelle in der EingabeSpalte mit
Return bestätigt wird, nach den Eingeben ( Excel auf bei Return - Sprung nach rechts eingestellt ) .
Ich sollte es aber auch schon beim Auswählen der Spalte haben , also wenn ich per linker Maustaste eine Zelle dieser Spalten anklicke ( ohne dass ich erst was reinschreibe ), sprich da stünde schon was drinne, und das wird bei Anwahl der Zelle gleich nochmals geprüft, bislang funktionierts nur beim verlassen der Zelle, und dass auch nur wenn man Text eingegeben hat.
Wäre Euch mordsmässig dankbar ;-)
Gruß udo
++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Private Sub Worksheet_Change(ByVal Target As Range)
Dim WsI As Worksheet
Dim C As Range
Set WsI = Worksheets("Grunddaten")
On Error GoTo Ende:
'----------------------------------------------------------------------------------------------- _
_
_
_
_
'vergleiche Spalte E ( Column 5 ) im Zeilenbereich von Zeile 7 bis 10000 alle Einträge ausser
'leere Zellen sollen ignoriert werden.
If Target.Validation.InCellDropdown Then
With WsI
'Suche im Tabellenblatt "Grunddaten" , und dort im Bereich F7:F10000 nach also _
gleichen Einträgen
'wird kein neuer Eintrag gefunden bleibt alles wie gehabt,
'wird ein neuer Eintrag erkannt, soll er in den Vorgabebereich ( Gültigkeitsbereich _
_
_
_
_
F7:F10000 ) mit eingeschrieben werden
Set C = .Range("F7:F10000").Find(ActiveSheet.Cells(ActiveCell.Row, 5), , , xlWhole)
If C Is Nothing Then
If MsgBox("Neuer Eintrag wurde erkannt. ( " & Target & " ) in die Vorgabe mit ü _
_
_
_
_
bernehmen ?" _
, vbYesNo, "") = vbNo Then Exit Sub
.Range("F65536").End(xlUp).Offset(1) = Target
.Range("F7:F10000").Sort .Range("F7"), xlAscending
End If
End With
End If
'----------------------------------------------------------------------------------------------- _
_
_
_
_
If Target.Validation.InCellDropdown Then
With WsI
Set C = .Range("H7:H10000").Find(Cells(ActiveCell.Row, 6), , , xlWhole)
If C Is Nothing Then
If MsgBox("Neuer Eintrag wurde erkannt. ( " & Target & " ) in die Vorgabe mit ü _
_
_
_
_
bernehmen ?" _
, vbYesNo, "") = vbNo Then Exit Sub
.Range("H65536").End(xlUp).Offset(1) = Target
.Range("H7:H10000").Sort .Range("H7"), xlAscending
End If
End With
End If
'----------------------------------------------------------------------------------------------- _
_
_
_
_
If Target.Validation.InCellDropdown Then
With WsI
Set C = .Range("J7:J10000").Find(Cells(ActiveCell.Row, 7), , , xlWhole)
If C Is Nothing Then
If MsgBox("Neuer Eintrag wurde erkannt. ( " & Target & " ) in die Vorgabe mit ü _
_
_
_
_
bernehmen ?" _
, vbYesNo, "") = vbNo Then Exit Sub
.Range("J65536").End(xlUp).Offset(1) = Target
.Range("J7:J10000").Sort .Range("J7"), xlAscending
End If
End With
End If
Ende:
Application.ScreenUpdating = True
End Sub