Daten aus Word auslesen und in Excel auflisten

ption Explicit
Public Enum SORT_BY
Sort_by_None
Sort_by_Name
Sort_by_Path
Sort_by_Size
Sort_by_Last_Access
Sort_by_Last_Modyfy
Sort_by_Date_Create
End Enum
Public Enum SORT_ORDER
Sort_Order_Ascending
Sort_Order_Descending
End Enum
Public Type FILEINFO
strFilename As String
strPath As String
lngSize As Long
dmtLastAccess As Date
dmtLastModify As Date
dmtDateCreate As Date
End Type
Public Sub Import()
Dim objFileSearch As clsFileSearch
Dim lngIndex As Long
Dim strSuwort As String
Dim i As Integer
Dim bolErg As Boolean
Dim Zelle_C As Long
Dim Zelle_R As Long
Dim Wert As Long
Dim iZeile As Long, tempZeile As Long, iZähler As Long
Dim WS1 As Worksheet, WS2 As Worksheet
'Vorhandene Daten im Ziel löschen
'ActiveWorkbook.Worksheets("ISR Import Database").AutoFilter.Sort.SortFields. _
Clear
If ActiveSheet.FilterMode Then ActiveSheet.ShowAllData
If Range("A3")  "" Then
Range("A3", ActiveCell.SpecialCells(xlLastCell)).EntireRow.Delete
Range("A3").Select
Else
Range("A3").Select
End If
Set objFileSearch = New clsFileSearch
'strSuwort = InputBox("Suchwort eingeben")
strSuwort = "XY"
With objFileSearch
.CaseSenstiv = False
.Extension = "*.xls"
.FolderPath = "D:\temp\"
.SearchLike = "*"
.SubFolders = False
If .Execute(Sort_by_Size, Sort_Order_Descending) > 0 Then
Application.ScreenUpdating = False
For lngIndex = 1 To .FileCount
With .Files(lngIndex)
Workbooks.Open (.strPath)                         'Workbook öffnen
On Error Resume Next
For i = 1 To Workbooks(.strFilename).Worksheets.Count
With Workbooks(.strFilename).Worksheets(i)
.Activate
bolErg = .Cells.Find(What:=strSuwort, LookIn:=xlValues, LookAt:= _
xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext,  _
MatchCase:=False).Activate
If bolErg Then
Zelle_C = ActiveCell.Column
Zelle_R = ActiveCell.Row
Set WS1 = Application.ActiveSheet
Set WS2 = Application.Workbooks("Suche.xlsm").Worksheets("Tabelle1")
For iZeile = WS1.Cells(WS1.Rows.Count, Zelle_C).End(xlUp).Row To Zelle_R + 1 Step -1
'If IsNumeric(WS1.Cells(iZeile, Zelle_C)) And WS1.Cells(iZeile, Zelle_C) And
Wert = WS1.Cells(iZeile, Zelle_C)
If Wert > 0 And _
WS1.Cells(iZeile, 2)  "" And _
WS1.Cells(iZeile, 3)  "" And _
Left(WS1.Cells(iZeile, 3), 4)  "Prob" And _
Left(WS1.Cells(iZeile, 3), 4)  "Offe" And _
Left(WS1.Cells(iZeile, 3), 4)  "Besc" Then
iZähler = iZähler + 1
tempZeile = WS2.Cells(WS2.Rows.Count, 1).End(xlUp).Row + 1
WS2.Rows(tempZeile).Insert Shift:=xlDown
WS2.Cells(tempZeile, 1) = WS1.Cells(1, 14)
WS2.Cells(tempZeile, 2) = WS1.Cells(iZeile, 1)
WS2.Cells(tempZeile, 3) = WS1.Cells(iZeile, 2)
WS2.Cells(tempZeile, 4) = WS1.Cells(iZeile, 3)
End If
Next iZeile
'MsgBox "Import erfolgreich!"
Else
MsgBox "Suchwort nicht gefunden"
bolErg = False
End If
End With
Next i
Workbooks(.strFilename).Close savechanges:=False   'Workbook schließen
End With
Next
Else
MsgBox "Keine Datei gefunden"
End If
Application.ScreenUpdating = True
End With
Set objFileSearch = Nothing
End Sub