Suchergebnis Fett

Sub Stichwortsuche()
Dim wsQuelle As Worksheet, wsZiel As Worksheet
Dim i&, firstAddress$, c, d As Range
Set wsQuelle = Worksheets("Grunddaten") 'Quelle
Set wsZiel = Worksheets("Ausgabe")
i = 1
For Each d In Sheets("Stichwörter").Range("A1:A90")
strSuchBegr = d.Value
With Intersect(wsQuelle.UsedRange, wsQuelle.Columns(1))
If InStr(strSuchBegr, "*") = 0 Then _
strSuchBegr = "*" & strSuchBegr & "*"
Set c = .Find(strSuchBegr, After:=wsQuelle.Cells(.Rows.Count, 1), LookIn:=xlValues, LookAt:=xlWhole)
If Not c Is Nothing Then
firstAddress = c.Address
Do
c.EntireRow.Copy _
Destination:=wsZiel.Cells(i, 1)
i = i + 1
Set c = .FindNext(c)
Loop While Not c Is Nothing And c.Address <> firstAddress
Else
MsgBox "Suchbegriff: " & strSuchBegr & " nicht gefunden!"
End If
End With
Next
End Sub