[vba] VBA macro that search for file in multiple subfolders

I have macro, if I put in cell E1 name of the file, macro search trough C:\Users\Marek\Desktop\Makro\ directory, find it and put the needed values in specific cells of my original file with macro.

Is it possible to make this work without specific folder location? I need something that can search trough C:\Users\Marek\Desktop\Makro\ with many subfolders in it.

My code:

Sub Zila1()
Dim SaveDriveDir As String, MyPath As String
Dim FName As Variant
Dim YrMth As String

SaveDriveDir = CurDir
MyPath = Application.DefaultFilePath    'or use "C:\Data"
ChDrive MyPath
ChDir MyPath
FName = Sheets("Sheet1").Range("E1").Text

If FName = False Then
    'do nothing
Else
    GetData "C:\Users\Marek\Desktop\Makro\" & FName & ".xls", "Vystupna_kontrola", _
        "A16:A17", Sheets("Sheet1").Range("B2:B3"), True, False

        GetData "C:\Users\Marek\Desktop\Makro\" & FName & ".xls", "Vystupna_kontrola", _
        "AE23:AE24", Sheets("Sheet1").Range("B3:B4"), True, False

        GetData "C:\Users\Marek\Desktop\Makro\" & FName & ".xls", "Vystupna_kontrola", _
        "AE26:AE27", Sheets("Sheet1").Range("B4:B5"), True, False

        GetData "C:\Users\Marek\Desktop\Makro\" & FName & ".xls", "Vystupna_kontrola", _
        "AQ59:AQ60", Sheets("Sheet1").Range("B5:B6"), True, False

        GetData "C:\Users\Marek\Desktop\Makro\" & FName & ".xls", "Vystupna_kontrola", _
        "AR65:AR66", Sheets("Sheet1").Range("B6:B7"), True, False

        End If

  ChDrive SaveDriveDir
  ChDir SaveDriveDir
End Sub

If this helps, you can also use FileSystemObject to retrieve all subfolders of a folder. You need to check the reference "Microsot Scripting Runtime" to get Intellisense and use the "new" keyword.

Sub GetSubFolders()

    Dim fso As New FileSystemObject
    Dim f As Folder, sf As Folder

    Set f = fso.GetFolder("D:\Proj\")
    For Each sf In f.SubFolders
        'Code inside
    Next

End Sub

I actually just found this today for something I'm working on. This will return file paths for all files in a folder and its subfolders.

Dim colFiles As New Collection
RecursiveDir colFiles, "C:\Users\Marek\Desktop\Makro\", "*.*", True
Dim vFile As Variant

For Each vFile In colFiles
     'file operation here or store file name/path in a string array for use later in the script
     filepath(n) = vFile
     filename = fso.GetFileName(vFile) 'If you want the filename without full path
     n=n+1
Next vFile


'These two functions are required
Public Function RecursiveDir(colFiles As Collection, strFolder As String, strFileSpec As String, bIncludeSubfolders As Boolean)
Dim strTemp As String
Dim colFolders As New Collection
Dim vFolderName As Variant
strFolder = TrailingSlash(strFolder)
strTemp = Dir(strFolder & strFileSpec)
Do While strTemp <> vbNullString
    colFiles.Add strFolder & strTemp
    strTemp = Dir
Loop
If bIncludeSubfolders Then

    strTemp = Dir(strFolder, vbDirectory)
    Do While strTemp <> vbNullString
        If (strTemp <> ".") And (strTemp <> "..") Then
            If (GetAttr(strFolder & strTemp) And vbDirectory) <> 0 Then
                colFolders.Add strTemp
            End If
        End If
        strTemp = Dir
    Loop
    'Call RecursiveDir for each subfolder in colFolders
    For Each vFolderName In colFolders
        Call RecursiveDir(colFiles, strFolder & vFolderName, strFileSpec, True)
    Next vFolderName
End If
End Function

Public Function TrailingSlash(strFolder As String) As String
If Len(strFolder) > 0 Then
    If Right(strFolder, 1) = "\" Then
        TrailingSlash = strFolder
    Else
        TrailingSlash = strFolder & "\"
    End If
End If
End Function

This is adapted from a post by Ammara Digital Image Solutions.(http://www.ammara.com/access_image_faq/recursive_folder_search.html).

This sub will populate a Collection with all files matching the filename or pattern you pass in.

Sub GetFiles(StartFolder As String, Pattern As String, _
             DoSubfolders As Boolean, ByRef colFiles As Collection)

    Dim f As String, sf As String, subF As New Collection, s
    
    If Right(StartFolder, 1) <> "\" Then StartFolder = StartFolder & "\"
    
    f = Dir(StartFolder & Pattern)
    Do While Len(f) > 0
        colFiles.Add StartFolder & f
        f = Dir()
    Loop
    
    If DoSubfolders then
        sf = Dir(StartFolder, vbDirectory)
        Do While Len(sf) > 0
            If sf <> "." And sf <> ".." Then
                If (GetAttr(StartFolder & sf) And vbDirectory) <> 0 Then
                        subF.Add StartFolder & sf
                End If
            End If
            sf = Dir()
        Loop
    
        For Each s In subF
            GetFiles CStr(s), Pattern, True, colFiles
        Next s
    End If

End Sub

Usage:

Dim colFiles As New Collection

GetFiles "C:\Users\Marek\Desktop\Makro\", FName & ".xls", True, colFiles
If colFiles.Count > 0 Then
    'work with found files
End If