In Dateien suchen und ersetzen, einschl. Unterverz

Sub DateienÄndern()
Dim blnGeändert As Boolean
Dim lngZähler As Long
Dim rngZelle As Range
Dim strDatei As String
Dim strSuche As String
Dim strErsatz As String
Dim strZelle As String
Dim strPfad As String
Dim wsTab As Worksheet
strPfad = ActiveSheet.Range("F3").Value
strSuche = ActiveSheet.Range("F1").Value
strErsatz = ActiveSheet.Range("F2").Value
ChDrive Left(strPfad, 3)
ChDir strPfad
strDatei = Dir("*.xl*", vbNormal)
Columns("A:B").ClearContents
Application.ScreenUpdating = False
Do While strDatei  ""
If strDatei  ThisWorkbook.Name Then
Workbooks.Open strPfad & "\" & strDatei
blnGeändert = False
For Each wsTab In ActiveWorkbook.Worksheets
Set rngZelle = wsTab.Cells.Find(strSuche)
If Not rngZelle Is Nothing Then
strZelle = rngZelle.Address
Do
rngZelle.Replace What:=strSuche, _
Replacement:=strErsatz, _
LookAt:=xlPart, _
SearchOrder:=xlByRows, _
MatchCase:=False
blnGeändert = True
Set rngZelle = wsTab.Cells.FindNext(After:=rngZelle)
If rngZelle Is Nothing Then Exit Do
Loop While rngZelle.Address  strZelle
End If
Next wsTab
ActiveWorkbook.Close True
If blnGeändert Then
lngZähler = lngZähler + 1
Cells(lngZähler, 1).Value = strDatei
Cells(lngZähler, 2).Value = Date
End If
End If
strDatei = Dir()
Loop
Application.ScreenUpdating = False
Columns("A:B").AutoFit
End Sub