Doppelten Suchbegriff einbauen????
20.08.2024 13:03:45
Kruemelmonstar
Danke euch habe ich diesen Code bekommen, der mir sehr hilft. Doch wenn ich nun Zwei Suchfaktoren möcht, Wie müsste man ihn Umschreiben.
Also R13 und R14 haben Suchbegriffe, die in dem Sheet Fassung zusammen in einer Zeile sind. Diese Zeile soll bei der Übersicht wiedergeben werden.
Einzeilnd wird dies ja schon mit code s.u. gemacht, aber Zwei suchbegriffe?
Die Aktivfeldfunktion ist KEIN Muss.
Sub Suche()
Dim rng As Range
Dim dbl_suchwert As String
Dim sfirstaddress As String
Dim Übersicht As Worksheet
Dim gültig_rng As Range
Dim sel_ok
Set gültig_rng = ActiveSheet.Range("R13,R15,R17,R19")
Set sel_ok = Application.Intersect(Selection, gültig_rng)
If sel_ok Is Nothing Then MsgBox "Keine gültige Zelle gewählt": Exit Sub 'Ausstieg A
If Selection = "" Then MsgBox "Kein Suchbegriff in der Zelle": Exit Sub 'Ausstieg B
If Range("A1") > "" Then Range("A1:O150").Clear 'gefundenen Bereich löschen
Application.ScreenUpdating = False 'Bildschirmaktualisierung aus: schneller
Set sh_Übers = Worksheets("Übersicht")
dbl_suchwert = Selection
With Sheets("Fassung") 'referenziert auf sheet
Sheets("Fassung").Range("A1:O1").Copy Sheets("Übersicht").Range("A1:O1")
Set such_rng = .Range("A:I")
Set rng = such_rng.Find(dbl_suchwert)
If Not rng Is Nothing Then
sfirstaddress = rng.Address
Do
.Range("A" & rng.Row & ":I" & rng.Row).Copy sh_Übers.Cells(Rows.Count, "A").End(xlUp).Offset(1, 0) 'direktkopie
Set rng = such_rng.FindNext(rng)
Loop While Not rng Is Nothing And rng.Address > sfirstaddress
Else
MsgBox "nicht gefunden"
End If
End With
End Sub
Anzeige