Makro´s beschleunigen

Sub F_Dateien_einlesen()
With Application
.ScreenUpdating = False
.Calculation = xlCalculationManual
.EnableEvents = False
End With
Dim spfad As String, sExt As String, sDatei As String
Dim wb1 As Workbook, WB2 As Workbook
Set wb1 = ThisWorkbook
spfad = Left(wb1.Path, InStrRev(wb1.Path, "\") - 0)
spfad = Left(spfad, InStrRev(spfad, "\")) & "Test\PPS\"
sExt = "*.f"
sDatei = Dir(spfad & sExt)
Application.ScreenUpdating = False
wb1.Worksheets(2).Cells.Delete
Do While Len(sDatei) > 0
Set WB2 = Workbooks.Open(spfad & sDatei)
WB2.Worksheets(1).Rows(3).Copy wb1.Worksheets(2).Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)
WB2.Close
sDatei = Dir()
Loop
With Application
.ScreenUpdating = True
.Calculation = xlCalculationAutomatic
.EnableEvents = True
End With
End Sub

Sub Pläne_markieren()
Dim rngMatch As Range, rngC As Range, rngA As Range, strMatch
Dim lngCol As Long, i As Integer
Application.ScreenUpdating = False
With Tabelle2
Set rngMatch = .Range(.Cells(1, 1), .Cells(Rows.Count, 1).End(xlUp))
End With
For Each rngA In Tabelle1.UsedRange.Cells
For Each rngC In rngMatch
lngCol = rngC.Font.Color
For i = 1 To Len(rngA) - Len(rngC) + 1
strMatch = Mid(rngA, i, Len(rngC))
Debug.Print strMatch
If strMatch = rngC Then
With rngA.Characters(i, Len(rngC)).Font
.Color = lngCol
.Bold = True
.Italic = True
End With
End If
Next i
Next rngC
Next rngA
End Sub