Application.FileSearch in Office 2007?

Applikation.Filesearch ist in Office 2007 nicht mehr vorhanden. Daher suche ich nach einer passenden Alternative.

Hallo,

das folgende Programm, war dazu da, in unserer Firma, einen markierten Bereich in einer Exceltabelle durchzugehen und dann in einem vorher angegebenen Ordner, nach Dateien des selben Names zu suchen.
Ich hoffe ihr könnt mir helfen, da derjenige der das Makro geschrieben hat, nicht mehr hier ist und nun ich diese Aufgabe bekommen habe.

Mit freundlichen Grüßen
Christian Edel

P.S.: Hier das Makro:
Und schonmal VIELEN DANKE für die Hilfe!!!!


Sub VerknüpfungenErstellen_V3()
Dim pfad As String
'in welchem Verzeichnis liegen die Dokumente?
Dim oSh As Object
Dim oFd As Variant
Dim nS As Object

Set oSh = GetObject("", "Shell.Application")
Set oFd = oSh.BrowseforFolder(0, _
"Bitte ein Verzeichnis auswählen ...", 0, "")
Set nS = oFd.Self
pfad = nS.Path

Set oSh = Nothing


If pfad = "" Then Exit Sub

'Markierte Zellen durchgehen
For Each cell In Selection

gefunden = False


With Application.FileSearch
.NewSearch
.LookIn = pfad
.SearchSubFolders = True
.Filename = cell.Value & ".pdf"
.MatchTextExactly = True
.FileType = msoFileTypeAllFiles

If .Execute() > 0 Then
Select Case .FoundFiles.Count
Case 1
'Verknüpfen
'MsgBox "LINK: " & .FoundFiles(1)
ActiveSheet.Hyperlinks.Add cell, .FoundFiles(1)
gefunden = True
Case Else
MsgBox "Es wurde mehr ale eine passende Datei " & cell.Value & ".pdf gefunden. Bitte manuell verknüpfen."
End Select
Else
'MsgBox "Es wurde keine Datei " & cell.Value & ".pdf gefunden."
End If
End With

If Not (gefunden) Then
'mit verkürztem Suchstring (ohne führende Nullen) nochmal durchgehen, falls nichts gefunden wurde.
'Beispiel cell.Value = DE000004006420C5
' suchstring = DE4006420C5
suchstring = cell.Value
While Mid(suchstring, 3, 1) = "0" And Not (gefunden)

'eine Null entfernen..
suchstring = Left(suchstring, 2) & Right(suchstring, Len(suchstring) - 3)

'..und nochmal suchen
With Application.FileSearch
.NewSearch '
.LookIn = pfad
.SearchSubFolders = True
.Filename = suchstring & ".pdf"
.MatchTextExactly = True
.FileType = msoFileTypeAllFiles

If .Execute() > 0 Then
Select Case .FoundFiles.Count
Case 1
'Verknüpfen
'MsgBox "LINK: " & .FoundFiles(1)
ActiveSheet.Hyperlinks.Add cell, .FoundFiles(1)
gefunden = True
Case Else
MsgBox "Es wurde mehr ale eine passende Datei " & suchstring & ".pdf gefunden. Bitte manuell verknüpfen."
End Select
Else
MsgBox "Es wurde keine Datei " & suchstring & ".pdf gefunden."
End If
End With

Wend
End If

Next

End Sub

Option Explicit
Option Compare Text

Const Msg1 = "Es wurde mehr als eine passende Datei zu %1.pdf gefunden. Bitte manuell verknüpfen."  
Const Msg2 = "Es wurde keine passende Datei zu %1.pdf gefunden."  

Dim Fso As Object, FileList As Object

Sub SetHyperlinks()
    Dim Dlg As FileDialog, File As Variant, c As Range
    Dim Path As String, SearchName As String, FoundCount As Long
   
    Set Dlg = Application.FileDialog(msoFileDialogFolderPicker)
    
    Dlg.Title = "Verzeichnis auswählen..."  
    Dlg.InitialFileName = "D:\Temp\"  'Start-Ordner  
    
    If Dlg.Show = False Then Exit Sub
    
    Set Fso = CreateObject("Scripting.FileSystemObject")  
    Set FileList = CreateObject("Scripting.Dictionary")  
   
    Call InitFileList(Fso.GetFolder(Dlg.SelectedItems(1)))
    
    For Each c In Selection
        If Not IsEmpty(c) Then
            FoundCount = 0
            
            For Each File In FileList.Items
                If c Like Fso.GetBaseName(File) Then
                    Path = File:  FoundCount = FoundCount + 1
                End If
            Next
            
            If FoundCount = 0 Then
                SearchName = c
                
                Do While (Mid(SearchName, 3, 1) = "0")  
                    SearchName = Left(c, 2) & Mid(SearchName, 4)
                    
                    For Each File In FileList.Items
                        If Fso.GetBaseName(File) Like SearchName Then
                            Path = File:  FoundCount = FoundCount + 1
                        End If
                    Next
                Loop
            End If
                
            If FoundCount = 1 Then
                ActiveSheet.Hyperlinks.Add c, Path
            ElseIf FoundCount > 1 Then
                MsgBox Replace(Msg1, "%1", c), vbInformation, "Dateisuche..."  
            Else
                MsgBox Replace(Msg2, "%1", c), vbInformation, "Dateisuche..."  
            End If
        End If
    Next
End Sub

Private Sub InitFileList(ByRef Folder)
    Dim File As Object, SubFolder As Object
    
    For Each File In Folder.Files
        If LCase(Fso.GetExtensionName(File.Name)) = "pdf" Then  
            FileList.Add FileList.Count + 1, File.Path
        End If
    Next
    
    For Each SubFolder In Folder.SubFolders
        Call InitFileList(SubFolder)
    Next
End Sub