Suche einschränken

Sub Schaltfläche433_Klicken()
Application.ScreenUpdating = False
ActiveWorkbook.Unprotect
Dim c               As Range
Dim Suchwert        As Variant
Dim ws              As Worksheet
Dim ersterFundort   As String
Dim i               As Integer, z As Long
z = 1
Application.ScreenUpdating = False
Suchwert = InputBox("Suchbegriff", "Suchbegriff")
If Suchwert = "" Then Exit Sub
For Each ws In Sheets
If ws.Name = "Suchergebnis" Then
Application.DisplayAlerts = False
ws.Delete
Application.DisplayAlerts = True
End If
Next
Sheets.Add After:=Sheets(Sheets.Count)
Set ws = ActiveSheet
ws.Name = "Suchergebnis"
ws.Cells(1, 1).Value = "Suchergebnis"
ws.Cells(1, 2).Value = "im Tabellenblatt"
ws.Cells(1, 3).Value = "Zelladresse"
ws.Cells(1, 4).Value = "PR-Nummer"
ws.Cells(1, 5).Value = "Eigenschaft"
ws.Cells(1, 6).Value = "Nummer der Familie"
ws.Cells(1, 7).Value = "Familie"
For i = 1 To Sheets.Count - 1
Set c = Sheets(i).Cells.Find(what:=Suchwert, lookat:=xlValue)
If Not c Is Nothing Then
Do Until c Is Nothing Or c.Address = ersterFundort
If ersterFundort = "" Then ersterFundort = c.Address
z = z + 1
With ws
.Cells(z, 3).Value = c.Address(False, False)
.Cells(z, 2).Value = Sheets(i).Name
.Hyperlinks.Add Anchor:=.Cells(z, 1), Address:="", _
SubAddress:=Sheets(i).Name & "!" & c.Address(False, False), _
TextToDisplay:=CStr(c)
'Spalten C bis D der gefundenen Zeile kopieren
With Sheets(i)
.Range(.Cells(c.Row, 1), .Cells(c.Row, 4)).Copy _
Destination:=ws.Cells(z, 4)
End With
End With
Set c = Sheets(i).Cells.FindNext(c)
Loop
End If
Set c = Nothing
ersterFundort = ""
Next
If z = 1 Then MsgBox Suchbegriff & "Suchbegriff wurde nicht gefunden.", vbInformation, " _
Suchergebnis nicht erfolgreich"
ws.Columns.AutoFit
ActiveWorkbook.Protect
End Sub