VBA macro that search for file in multiple subfolders

Question

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

Tete1805 · Accepted Answer · 2013-12-20T17:32:26.787

Just for fun, here's a sample with a recursive function which (I hope) should be a bit simpler to understand and to use with your code:

Function Recurse(sPath As String) As String

    Dim FSO As New FileSystemObject
    Dim myFolder As Folder
    Dim mySubFolder As Folder

    Set myFolder = FSO.GetFolder(sPath)
    For Each mySubFolder In myFolder.SubFolders
        Call TestSub(mySubFolder.Path)
        Recurse = Recurse(mySubFolder.Path)
    Next

End Function

Sub TestR()

    Call Recurse("D:\Projets\")

End Sub

Sub TestSub(ByVal s As String)

    Debug.Print s

End Sub

Edit: Here's how you can implement this code in your workbook to achieve your objective.

Sub TestSub(ByVal s As String)

    Dim FSO As New FileSystemObject
    Dim myFolder As Folder
    Dim myFile As File

    Set myFolder = FSO.GetFolder(s)
    For Each myFile In myFolder.Files
        If myFile.Name = Range("E1").Value Then
            Debug.Print myFile.Name 'Or do whatever you want with the file
        End If
    Next

End Sub

Here, I just debug the name of the found file, the rest is up to you. ;)

Of course, some would say it's a bit clumsy to call twice the FileSystemObject so you could simply write your code like this (depends on wether you want to compartmentalize or not):

Function Recurse(sPath As String) As String

    Dim FSO As New FileSystemObject
    Dim myFolder As Folder
    Dim mySubFolder As Folder
    Dim myFile As File

    Set myFolder = FSO.GetFolder(sPath)

    For Each mySubFolder In myFolder.SubFolders
        For Each myFile In mySubFolder.Files
            If myFile.Name = Range("E1").Value Then
                Debug.Print myFile.Name & " in " & myFile.Path 'Or do whatever you want with the file
                Exit For
            End If
        Next
        Recurse = Recurse(mySubFolder.Path)
    Next

End Function

Sub TestR()

    Call Recurse("D:\Projets\")

End Sub

Thanks, I think this is exactly what I´m looking for. Are sure this code is right? Because in my immediate panel I´m not getting any response from Debug.Print — trenccan, Dec 24 '13 at 12:06
It will only debug the name of a file if one of the files in your subfolders matches the name in E1 (so be sure you validate the condition first). If you want to see all files in the debug window, just comment the condtion lines (the 'if' and 'end if' and the 'exit for') — Tete1805, Dec 26 '13 at 20:15
Please how I can improve this part of code: For Each myFile In mySubFolder.Files If myFile.Name = Sheets("Sheet1").Range("O5").Value & ".xlsx" Then ....... if I want to also find a file which has xls extension. Better say I want to find file with name that I put in O5 range doesnt matter if it is xls or xlsx. Thanks! — trenccan, Jan 08 '14 at 15:14
@trenccan Sorry mate, I haven't checked this thread recently. Have you tried looking into InStr()? Like `If InStr(1, myFile.Name, Sheets("Sheet1").Range("O5").Value) Then...` — Tete1805, Feb 19 '14 at 11:03

score 6 · Answer 2 · edited Aug 17 '20 at 19:07

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

I've used this for myself and now I'm trying to figure out how to change a cell color if there is no file found in the folder/subfolders. It works perfectly other than my figuring this out. If you could help that would be awesome. I'll link my question here. [https://stackoverflow.com/questions/62918340/changing-cell-color-while-adding-items-to-a-collection] — JoshL, Jul 15 '20 at 16:39

score 3 · Answer 3 · answered Dec 19 '13 at 17:39

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

score 2 · Answer 4 · edited Feb 28 '18 at 06:19

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).

What references did you have to set to early bind these things? — Daniel L. VanDenBosch, Jan 06 '20 at 19:55

VBA macro that search for file in multiple subfolders

4 Answers4

Linked

Related