Zelle auf Übereinstimmung prüfen
09.06.2017 07:44:08
Sigi
ich möchte nach verlassen einer Zelle prüfen lassen ob der eingebene Wert in einer Liste vorhanden ist.
Wenn nicht dann soll eine UF erscheinen. Wenn der Wert vorhanden ist, dann
sollen die Werte aus den Nebenzellen übertragen werden.
Leider erscheint die UF immer auch wenn der Wert vorhanden ist.
Danke!
Gruß
Sigi
https://www.herber.de/bbs/user/114145.xlsm 'Code auskommentiert
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim wks As Worksheet
Dim ii&, loEnde%
Dim iRow&
iRow = 2
Set wks = Sheets("Buch")
Select Case Target.Column
Case 7, 20, 33, 46, 59, 72, 85, 98, 111, 124, 137, 150
If Len(ActiveCell.Value) = 4 Then
Do Until IsEmpty(wks.Cells(iRow, 1))
If wks.Cells(iRow, 1).Value = ActiveCell.Value Then
GoTo Step1
Else
GoTo Step2
End If
Loop
End If
Step1:
With wks
For ii = 2 To .Cells(.Rows.Count, 8).End(xlUp).Row
If .Cells(ii, 8) = ActiveCell.Offset(0, -2).Value And .Cells(ii, 9) = _
ActiveCell.Value * 1 Then
Exit For
GoTo Ende
Else
.Cells(ii + 1, 8) = ActiveCell.Offset(0, -2).Value
.Cells(ii + 1, 9) = ActiveCell.Value * 1
.Cells(ii + 1, 10).FormulaR1C1 = "=VLOOKUP(RC[-1],C[-9]:C[-8],2,0)"
loEnde = .Cells(Rows.Count, 8).End(xlUp).Row
.Range(.Cells(2, 8), .Cells(loEnde, 10)).Sort _
Key1:=.Range("H1"), Order1:=xlAscending, _
Header:=xlYes, OrderCustom:=1, _
MatchCase:=False, Orientation:=xlTopToBottom
GoTo Ende
End If
Next ii
End With
Step2:
UF1.Show
Ende:
End Select
Set wks = Nothing
End Sub