Private Sub Worksheet_Change(ByVal Target As Range)
Dim strFirst As String
Dim lngColumn As Long
Dim rngUnion As Range
Dim rngFound As Range
Dim rngTMP As Range
Dim lngRow As Long
On Error GoTo Fin
If Target.Count > 1 Then Exit Sub
If Not Intersect(Target, Cells(1, 2)) Is Nothing Then
If Trim(Target.Value) = "" Then _
Cells.EntireRow.Hidden = False: Exit Sub
Application.ScreenUpdating = False
Application.EnableEvents = False
lngRow = IIf(Len(Cells(Rows.Count, 1)), Rows.Count, _
Cells(Rows.Count, 1).End(xlUp).Row)
lngColumn = Cells.Find _
("*", , , , xlByColumns, xlPrevious).Column
Set rngTMP = Range(Cells(3, 1), Cells(lngRow, lngColumn))
Set rngFound = rngTMP.Find(Cells(1, 2).Text, _
After:=Range("A3"), LookIn:=xlValues, LookAt:=xlPart)
If Not rngFound Is Nothing Then
strFirst = rngFound.Address
Do
If Not rngUnion Is Nothing Then
Set rngUnion = Application.Union(rngUnion, _
Cells(rngFound.Row, 1)).EntireRow
Else
Set rngUnion = Cells(rngFound.Row, 1).EntireRow
End If
Set rngFound = rngTMP.FindNext(rngFound)
Loop While rngFound.Address <> strFirst
Else
Target.ClearContents
MsgBox "Nothing found!"
End If
Else
Exit Sub
End If
Application.Goto Range("B1")
If Not rngUnion Is Nothing Then
rngTMP.Rows.Hidden = True
rngUnion.Hidden = False
End If
Fin:
If Err.Number <> 0 Then MsgBox "Fehler: " & _
Err.Number & " " & Err.Description
Application.ScreenUpdating = True
Application.EnableEvents = True
Set rngUnion = Nothing
Set rngFound = Nothing
Set rngTMP = Nothing
End Sub