Application.Filesearch Replacement For Office 2007

If you have ever used completed a search for files using VBA you probably made use of Application.Filesearch.  However, if you’ve updated to Office 2007 or 2010 you may have noticed that Filesearch has been removed… but the (very) old Dir remains, so you can use this instead, an example of which follows:

Sub FileSearch()
    Dim fso As Object
    Dim FileName As String
    Dim strArr(1 To 65536, 1 To 1) As String
    Dim i As Long

    ' Set the directory / filename you are looking for
    Const strDir As String = "C:\Your\File\Path"
    Const SearchTerm As String = "YourFileNameTerm"

    ' Complete the search
    Let FileName = Dir$(strDir & "\*" & SearchTerm & "*.xls")
    Do While FileName <> vbNullString
        ' For each file found load to the array
        Let i = i + 1
        Let strArr(i, 1) = strDir & "\" & FileName
        Let FileName = Dir$()
    Loop

    ' Search within sub-folders
    Set fso = CreateObject("Scripting.FileSystemObject")
    Call RecurseSubFolders(fso.GetFolder(strDir), strArr(), i, SearchTerm)

    ' Tidy up and copy the results to the active worksheet
    Set fso = Nothing
    If i > 0 Then
        Range("A1").Resize(i).Value = strArr
    End If

End Sub

Private Sub RecurseSubFolders( _
    ByRef Folder As Object, _
    ByRef strArr() As String, _
    ByRef i As Long, _
    ByRef SearchTerm As String)

    Dim SubFolder As Object
    Dim FileName As String

    ' Search sub folders
    For Each SubFolder In Folder.SubFolders
        Let FileName = Dir$(SubFolder.Path & "\*" & SearchTerm & "*.xls")
        Do While FileName <> vbNullString
            Let i = i + 1
            Let strArr(i, 1) = SubFolder.Path & "\" & FileName
            Let FileName = Dir$()
        Loop
        Call RecurseSubFolders(SubFolder, strArr(), i, SearchTerm)
    Next
End Sub