Suchen und finden

Sub SearchAllSheets()
Dim intI As Integer
Dim shBlatt As Worksheet
Dim rngErgebnis As Range
Dim strAdresse As String
Dim strSuchbegriff As String
strSuchbegriff = InputBox("Geben Sie den Suchbegriff ein! / Enter the search string", strInfo)
If strSuchbegriff = "" Then Exit Sub
Application.ScreenUpdating = False
Application.DisplayAlerts = False
intI = 1
For Each shBlatt In Worksheets
If shBlatt.Name = "Ergebnisse" Then shBlatt.Delete
Next
Sheets.Add After:=Worksheets(Worksheets.Count), _
Type:=xlWorksheet
Worksheets(Worksheets.Count).Name = "Ergebnisse"
For Each shBlatt In ActiveWorkbook.Worksheets
shBlatt.Activate
Set rngErgebnis = shBlatt.UsedRange.Find(What:=strSuchbegriff, _
LookIn:=xlValues, LookAt:=xlPart)
If Not rngErgebnis Is Nothing Then
strAdresse = rngErgebnis.Address
Do
rngErgebnis.Activate
With Worksheets("Ergebnisse")
.Hyperlinks.Add _
Anchor:=.Range("A" & intI), _
Address:="", _
SubAddress:="'" & shBlatt.Name & "'!" & _
rngErgebnis.AddressLocal
End With
intI = intI + 1
Set rngErgebnis = Cells.FindNext(After:=ActiveCell)
If strAdresse = rngErgebnis.Address Then Exit Do
Loop
End If
Next shBlatt
If intI = 1 Then
MsgBox "Keine Werte gefunden! / No match found", vbExclamation, strInfo
End If
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Worksheets("Ergebnisse").Activate
End Sub