Geschwindigkeit der For / Next - Suche

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
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 = "Pos"
With objFileSearch
.CaseSenstiv = False
.Extension = "*.xls*"
.FolderPath = "D:\temp\"
.SearchLike = "*"
.SubFolders = False
'.SubFolders = True
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
Set WS1 = Application.ActiveSheet
Set WS2 = Application.Workbooks("Suche.xlsm").Worksheets("Import database")
Zelle_C = ActiveCell.Column
Zelle_R = ActiveCell.Row
For iZeile = WS1.Cells(WS1.Rows.Count, Zelle_C).End(xlUp).Row To Zelle_R + 1 Step -1
If WS1.Cells(iZeile, Zelle_C)  "" And _
WS1.Name  "Zusammenfassung" 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) = ActiveWorkbook.Name
WS2.Cells(tempZeile, 5) = WS1.Cells(iZeile, 3)
If WS1.Cells(iZeile, Zelle_C + 9) > 0 Then
WS2.Cells(tempZeile, 6) = WS1.Cells(iZeile, Zelle_C + 9)
WS2.Cells(tempZeile, 7) = "A"
End If
If WS1.Cells(iZeile, Zelle_C + 10) > 0 Then
WS2.Cells(tempZeile, 6) = WS1.Cells(iZeile, Zelle_C + 10)
WS2.Cells(tempZeile, 7) = "B"
End If
If WS1.Cells(iZeile, Zelle_C + 11) > 0 Then
WS2.Cells(tempZeile, 6) = WS1.Cells(iZeile, Zelle_C + 11)
WS2.Cells(tempZeile, 7) = "C"
End If
If WS1.Cells(iZeile, Zelle_C + 12) > 0 Then
WS2.Cells(tempZeile, 6) = WS1.Cells(iZeile, Zelle_C + 12)
WS2.Cells(tempZeile, 7) = "D"
End If
If WS1.Cells(iZeile, Zelle_C + 13) > 0 Then
WS2.Cells(tempZeile, 6) = WS1.Cells(iZeile, Zelle_C + 13)
WS2.Cells(tempZeile, 7) = "E"
End If
If WS1.Cells(iZeile, Zelle_C + 14) > 0 Then
WS2.Cells(tempZeile, 6) = WS1.Cells(iZeile, Zelle_C + 14)
WS2.Cells(tempZeile, 7) = "F"
End If
If WS1.Cells(iZeile, Zelle_C + 15) > 0 Then
WS2.Cells(tempZeile, 6) = WS1.Cells(iZeile, Zelle_C + 15)
WS2.Cells(tempZeile, 7) = "G"
End If
'WS2.Cells(tempZeile, 8) = getZahl(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