'+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 'entwickelt von Winfried Radner 'e-mail: Wolf.W.Radzinski@gmx.de 'Benutzung frei - ohne Gewähr '+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ '+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ '+ '+ sucht in "quelle" nach Übereinstimmungen mit "kriterien" '+ und in in Abhängigkeit des Wertes "aktion" werden '+ (bei aktion=1 oder nicht vorhanden ) '+ gefundene Zellen in "ziel" kopiert '+ (bei aktion =2) '+ NUR WENN zusätzlich InversSelection installiert wurde! '+ bleiben ausschließlich Trefferzeilen sichtbar '+ - außer es werden gar keine Treffer gefunden, '+ dann könnte man statt Exit Sub auch eine MsgBox anzeigen! '+ '+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Sub suche_und_filtern(quelle As Range, ziel As Range, kriterien As Range, Optional aktion = 1) Dim r As Range Dim r1 As Range Dim menge As New Collection Dim z As Range Dim i As Long On Error GoTo err_gef For Each z In kriterien Set r1 = quelle.Find(What:=z.FormulaLocal, LookAt:=xlWhole, _ SearchOrder:=xlByRows, MatchCase:=True) Set r = r1 Do While Not r Is Nothing menge.Add r Set r = quelle.FindNext(r) If r.Address = r1.Address Then Set r = Nothing Loop Next z If IsError(menge.Count) Then Exit Sub ' nichts gefunden Select Case aktion Case 1: For i = 1 To menge.Count ziel.Cells(i) = menge.Item(i) Next i Case 2: Set sel = menge.Item(1).EntireRow If menge.Count > 1 Then For i = 2 To menge.Count Set sel = Union(sel, menge.Item(i).EntireRow) Next i End If sel.Select InversSelection Selection.Rows.Hidden = True Case Else: End Select Exit Sub err_gef: MsgBox "Fehler" End Sub ' gefiltert wird Spalte D die Kriterien stehen in A1:A8 ' eine Überschrift wie in Excel ist NICHT notwendig! ' wenn die aktion 2 weggelassen wird, dann werden die Ergebnisse ' in Spalte E eingetragen, wenn aktion=2 dann werden ' alle NICHT-Trefferzeilen unsichtbar (hidden = true) Sub filtere() With ActiveSheet suche_und_filtern .[D:D], .[E:E], .[a1:a8], 2 End With End Sub 'blendet unsichtbare Zeilen wieder ein! Sub einblenden() ActiveSheet.Rows.Hidden = False End Sub