Filesearch funktioniert ab Excel 2007 nicht mehr

Sub Datei_öffnen()

Dim Pfad As String, Dateiname As String
Pfad = S:\Bla\
Dateiname = Activecell.Value & .xls

With Application.Filesearch
  .LookIn = Pfad
  .SearchSubFolders = True
  .FileName = Dateiname
  If .Execute() > 0 Then
    Workbooks.Open (.FoundFiles(1))
  End If
End With

End Sub

dir *.xls /b > liste.txt

Option Explicit

Sub Datei_oeffnen_mit_FSO()
->fuer FSO muss unter Extras->Verweise Microsoft Scripting Runtime angehakt sein
 Dim fso As FileSystemObject
 Dim sPfad As String, sFileName As String, sFileNameFull As String
 
 sPfad = D:\00_TestExcel\Test\
 sFileName = xxxx.xls
 
 Set fso = New Scripting.FileSystemObject
 
 sFileNameFull = FindFile(fso, sPfad, sFileName)

 If sFileNameFull <>  Then Workbooks.Open (sFileNameFull)

Aufraeumen:
 Set fso = Nothing
End Sub
'-------------------------------------------------------------------------------------------------------------------
Private Function FindFile(fso As FileSystemObject, sPath As String, ByVal sFileName As String) As String
 
 Dim Folder As Folder, Folder2 As Folder

 On Error GoTo err_Handler
 
 Set Folder = fso.GetFolder(sPath)

 FindFile = Dir$(fso.BuildPath(Folder.Path, sFileName), vbNormal Or vbReadOnly)

 If FindFile <>  Then FindFile = Folder.Path & Application.PathSeparator & sFileName: GoTo Aufraeumen
 
 If Folder.SubFolders.Count > 0 Then
  For Each Folder2 In Folder.SubFolders
   FindFile = FindFile(fso, Folder2.Path, sFileName)
   If FindFile <>  Then Exit For
  Next
 End If

Aufraeumen:
 Set Folder = Nothing: Set Folder2 = Nothing
 On Error GoTo 0
 Exit Function

err_Handler:
 FindFile = FEHLER
 Resume Next
End Function

fuer FSO muss unter [color=red]Extras[/color]->Verweise Microsoft Scripting Runtime angehakt sein

Option Explicit

Sub Datei_oeffnen_mit_FSO()
->fuer FSO muss im VB-Editor unter Extras->Verweise Microsoft Scripting Runtime angehakt sein
 Dim oFso As FileSystemObject
 Dim sPfad As String, sFileName As String, sFileNameFull As String
 
 sPfad = D:\00_TestExcel\Test
 sFileName = xxxx.xls
 
->FileSystemObject für den Zugriff auf Verzeichnis-Struktur erzeugen
 Set oFso = New Scripting.FileSystemObject
 
 sFileNameFull = FindFile(oFso, sPfad, sFileName)

 If sFileNameFull <>  Then Workbooks.Open (sFileNameFull)

Aufraeumen:
 Set oFso = Nothing
End Sub
Private Function FindFile(oFso As FileSystemObject, sPfad As String, sFileName As String) As String
 
 Dim oVerzeichnis As Folder, oVerzeichnis2 As Folder

 On Error GoTo err_Handler
 
->Verzeichnis lesen
 Set oVerzeichnis = oFso.GetFolder(sPfad)

->prüfen, ob Datei im Verzeichnis vorliegt UND die Eigenschaft normal oder schreibgeschützt hat
 FindFile = Dir$(oFso.BuildPath(oVerzeichnis.Path, sFileName), vbNormal Or vbReadOnly)

->gefunden ? ja-> dann vollständigen Filenamen als Rückgabe setzen und Schluß
 If FindFile <>  Then FindFile = oFso.BuildPath(oVerzeichnis.Path, sFileName): GoTo Aufraeumen
 
->File in diesem Verzeichnis nicht vorhanden -> alle Unterverzeichnisse nacheinander durchsuchen
 If oVerzeichnis.SubFolders.Count > 0 Then
  For Each oVerzeichnis2 In oVerzeichnis.SubFolders
   FindFile = FindFile(oFso, oVerzeichnis2.Path, sFileName)
  ->wenn Filename gefunden -> Schluß
   If FindFile <>  Then Exit For
  Next
 End If

Aufraeumen:
->Objekte löschen, damit sie von der GarbageCollection weggeräumt werden können
 Set oVerzeichnis = Nothing: Set oVerzeichnis2 = Nothing
 On Error GoTo 0
 Exit Function

err_Handler:
 FindFile = FEHLER
 Resume Next
End Function