Daten aus Word mit Layout/Excelsuche in Textfelder

Sub finden()
' Startblatt merken, da hier nicht gesucht werden soll
Dim WshShell As Object
Application.ScreenUpdating = False
On Error Resume Next
Sheets("Suchergebnis").Select
mblatt = ActiveSheet.Name
Sheets("Hauptmenü").Select
msuch = Range("C5") 'Application.InputBox("Bitte den Suchtext eingeben", , Range("c5"))
If msuch = False Then
Exit Sub
End If
If Len(msuch) = 0 Then
MsgBox "Es muss schon ein Suchtext eingegeben werden"
Exit Sub
End If
' Alte gefundene Einträge löschen
Sheets("Suchergebnis").Select
Columns("A:B").Select
Selection.Clear
Cells(1, 1).Value = "Gefundene Einträge für die Suche nach: " + msuch
Cells(1, 2).Value = "Fundstelle"
' alte vergebene Namen löschen
z = 1
While z  Sheets(i).Name Then
If Sheets(i).Visible Then
Worksheets(i).Select
If IsDate(msuch) Then
Set C = Cells.Find(DateValue(msuch), LookIn:=xlValues, Lookat:=xlPart)
Else
If IsNumeric(msuch) Then
Set C = Cells.Find(Val(msuch), LookIn:=xlValues, Lookat:=xlPart)
Else
Set C = Cells.Find(msuch, LookIn:=xlValues, Lookat:=xlPart)
End If
End If
If Not C Is Nothing Then
firstAddress = C.Address
Do
C.Select
' Name für gefundene Zelle vergeben (reiser1 ....)
ActiveWorkbook.Names.Add Name:="Suche" + Trim(Str(s)), RefersTo:="=" +  _
Selection.Address
Sheets(mblatt).Cells(z, 1).Value = C.Value
Sheets(mblatt).Cells(z, 2).Value = Sheets(i).Name + "!" + C.Address
' Hyperlink eintragen in den Eintrag der gefundenen Stelle
Sheets(mblatt).Select
Cells(z, 1).Select
ActiveSheet.Hyperlinks.Add Anchor:=Selection, Address:="", SubAddress:=  _
_
"Suche" + Trim(Str(s)), TextToDisplay:=C.text
s = s + 1
Sheets(i).Select
z = z + 1
Set C = Cells.FindNext(C)
Loop While Not C Is Nothing And C.Address  firstAddress
End If
End If
End If
Next
Sheets("Hauptmenü").Select
Range("C5:F6").ClearContents
Suchergebnis.Show False
End Sub