Recursive Search Through Subfolders BACK to Root Directory

Question

I have a function that works to search through the subfolders of a given directory and finds the file name I need. However, it only goes through one set of subfolders, finding

Answer 1

Here is a routine you may be able to adapt to your use, if you are running Excel under Windows.

• Pick a base folder using the Excel folder picker routine
• Enter a file name mask (eg: Book1.xls*)
• Uses the Dir command window command to check all the folders and subfolders for files that start with Book1.xls
• The results of the command are written to a temporary file (which is deleted at the end of the macro)
  • There is a way to write it directly to a VBA variable, but I see too much screen flicker when I've done that.
• The results are then collected into a vba array, and written to a worksheet, but you can do whatever you want with the results.

---

Option Explicit
'set references to
'   Microsoft Scripting Runtime
'   Windows Script Host Object model
Sub FindFile()
    Dim WSH As WshShell, lErrCode As Long
    Dim FSO As FileSystemObject, TS As TextStream
    Dim sTemp As String
    Dim sBasePath As String
    Dim vFiles As Variant, vFullList() As String
    Dim I As Long
    Dim sFileName As String

    sTemp = Environ("Temp") & "\FileList.txt"

'Select base folder
With Application.FileDialog(msoFileDialogFolderPicker)
    .AllowMultiSelect = False
    If .Show = -1 Then 'if OK is pressed
        sBasePath = .SelectedItems(1)
    Else
        Exit Sub
    End If
End With

'File name mask
sFileName = InputBox("Entire File Mask", "File Finder")

Set WSH = New WshShell
lErrCode = WSH.Run("CMD /c dir """ & sBasePath & "\*" & sFileName & """ /A-D /B /S > " & sTemp, xlHidden, True)

If Not lErrCode = 0 Then
    MsgBox "Problem Reading Directory" & _
        vbLf & "Error Code " & lErrCode
    Exit Sub
End If


Set FSO = New FileSystemObject
Set TS = FSO.OpenTextFile(sTemp, ForReading, False, TristateFalse)

vFiles = Split(TS.ReadAll, vbLf)
TS.Close
FSO.DeleteFile sTemp
Set FSO = Nothing
Set WSH = Nothing

ReDim vFullList(1 To UBound(vFiles), 1 To 1)
For I = 1 To UBound(vFiles)
    vFullList(I, 1) = vFiles(I)
Next I

Dim rDest As Range
Set rDest = Cells(1, 2).Resize(UBound(vFullList, 1), UBound(vFullList, 2))

With rDest
    .EntireColumn.Clear
    .Value = vFullList
    .EntireColumn.AutoFit
End With

End Sub