VBA Recursive Folder search for specific Folder and File combo

[Gojira]

Hi

I'm trying to find a set of files that contain data I want to manipulate. End goal is to collate all the data from each file matching my criteria. However, I'm struggling at the moment as the function I'm using to search is crashing out.

I believe that it's failing due to either a file being corrupt or the path & filename being searched being too long for VBA / Excel to handle.

However - I am 99.99% confident that it will never fail for the files in the folder that I'm looking for. I've done some reasonably exhaustive testing and it's only ever failed on files in folders I don't care about. So I'm trying to refine the search to only look for the matching filename (*Finance Tracker*.xlsm) in a specific subfolder.

Unfortunately, because I've used code recommended to other people for recursive searching, I'm struggling to identify where I need to amend it to get the output I want.

In an ideal world I'd like to be able to use a wildcard value in the search path underlined in the code so the end of it reads \Projects\*\Controls\ and therefore skips searching all the other subfolders of the \*\ level (which is the project names).

Hope that makes sense... can anyone help me?


The code I'm using is:

Sub Get_Weekly_Costs()
    
    Dim wbSource As Workbook
    Dim wbDest As Workbook
    Dim i As Integer
    Dim colFiles As New Collection
    Dim vFile As Variant
    Dim FoundCell As Range
    Dim LastRow As Integer
    Dim Project_Name As String


          
    
    Application.ScreenUpdating = False


    ThisWorkbook.Sheets("Weekly Costs").Select
    Set wbDest = ActiveWorkbook
    
    RecursiveDir colFiles, [U]"C:\Users\" & Environ$("Username") & "\<Company>\Projects\"[/U], "*Finance Tracker*.xlsm", True


    i = 2
    LastRow = 1


    For Each vFile In colFiles
        Debug.Print vFile
            
        Workbooks.Open Filename:=vFile, ReadOnly:=True
        
        //Do some stuff to the file that's not important right now
        
        ActiveWorkbook.Close savechanges:=False
        i = i + 1
    Next vFile


    Application.ScreenUpdating = True
    
End Sub




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


    'Add files in strFolder matching strFileSpec to colFiles
    strFolder = TrailingSlash(strFolder)
    'Debug.Print strFolder
    strTemp = Dir(strFolder & strFileSpec)
    
    Dim v As Variant


    Do While strTemp <> vbNullString
        colFiles.Add strFolder & strTemp
        strTemp = Dir
    Loop


    If bIncludeSubfolders Then
        'Fill colFolders with list of subdirectories of strFolder
        strTemp = Dir(strFolder, vbDirectory)
        'Debug.Print "Temp " & strTemp
 
        Do While strTemp <> vbNullString
            If (strTemp <> ".") And (strTemp <> "..") Then
            Debug.Print "strTemp = " & strTemp
               If (GetAttr(strFolder & strTemp) And vbDirectory) <> 0 Then
                    colFolders.Add strTemp
                    For Each v In colFolders
                        Debug.Print v
                    Next v
                End If
            End If
            strTemp = Dir
            
            'Debug.Print "Temp2" & strTemp
        Loop




        'Call RecursiveDir for each subfolder in colFolders
        For Each vFolderName In colFolders
            'Debug.Print vFolderName
                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

 

[DanteAmor]

Try the following

Dim rutas As New Collection
'
Sub CopiarArchivosXls()
'Lee archivos
    '
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    '
    ruta = "C:\Users\" & Environ$("Username") & "\Projects\"   'init path
    wilddir = "Controls"                                        'wildcard value in the search path
    wmatch = "Finance Tracker"                           'matching filename
    ext = "xls*"                                                   'extension file
    '
    ActiveSheet.Cells.Clear
    rutas.Add ruta
    Call AgregaDir(ruta)
    '
    i = 2
    For Each sd In rutas
        If InStr(1, sd, wilddir) > 1 Then
            arch = Dir(sd & "\*." & ext)
            Do While arch <> ""
                If InStr(1, arch, wmatch) > 0 Then
                    If Right(sd, 1) <> "\" Then sd = sd & "\"
                    'Workbooks.Open Filename:=sd & arch, ReadOnly:=True
                    'Do some stuff to the file that's not important right now
                    'ActiveWorkbook.Close savechanges:=False
                    Cells(i, "A").Value = sd
                    Cells(i, "B").Value = arch
                    i = i + 1
                End If
                arch = Dir()
            Loop
        End If
    Next
    '
    Set rutas = Nothing
    Application.ScreenUpdating = True
    MsgBox "End", vbInformation, "FILES"
End Sub
'
Sub AgregaDir(lpath)
'Add directorios
    '
    Dim SubDir As New Collection
    If Right(lpath, 1) <> "\" Then lpath = lpath & "\"
    DirFile = Dir(lpath & "*", vbDirectory)
    Do While DirFile <> "" 'Add subdir to collection
        If DirFile <> "." And DirFile <> ".." Then
            If ((GetAttr(lpath & DirFile) And vbDirectory) = 16) Then
                SubDir.Add lpath & DirFile
            End If
        End If
        DirFile = Dir
    Loop
    For Each sd In SubDir
        rutas.Add sd
        Call AgregaDir(sd)
    Next
End Sub

 

[Gojira]

Hi Dante,

Thanks for the code suggestion. Unfortunately this runs into the same problem.

The issue is in the 'AgregaDir' subroutine, specifically this line:

If ((GetAttr(lpath & DirFile) And vbDirectory) = 16) Then

which gets a 'File Not Found' error at some point during execution.

I've tried adding an additional IF statement before that line of code that tests if 'lpath' includes 'Controls' but this just causes the code to stop after the first loop (turns out that was a dumb idea!)

I think I want something that does some kind of double loop. The first time through it goes through the 'Projects' folder and adds all of the subfolders (i.e. the named project folders) to a collection.
Then, it goes through each of those paths '*\Projects\Project1\', '*\Projects\Project2\', and so on and looks for the Controls folder - ignoring all of the other subfolders, and it adds each of those paths to a collection.
Then it looks for the right filename and does the rest of what I want.

Does that make sense? Would that work?

Working with collections like this is new ground for me in VBA so I'm not entirely sure what I'm doing.

 

[DanteAmor]

I think I want something that does some kind of double loop. The first time through it goes through the 'Projects' folder and adds all of the subfolders (i.e. the named project folders) to a collection.
Then, it goes through each of those paths '*\Projects\Project1\', '*\Projects\Project2\', and so on and looks for the Controls folder - ignoring all of the other subfolders, and it adds each of those paths to a collection.

That's what the macro does, first get all the folders starting in the initial folder and then, in another loop, discard the folders and get the files from the correct folders. But the problem happens in the first cycle.

Let's see which folder or file has the problem

Try the following on a sheet

Dim rutas As New Collection
Dim i
'
Sub CopiarArchivosXls()
'Lee archivos
    '
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    '
    ruta = "C:\Users\" & Environ$("Username") & "\Projects\"   'init path
    ruta = "C:\trabajo\"
    wilddir = "Controls"                                        'wildcard value in the search path
    wmatch = "Finance Tracker"                                  'matching filename
    ext = "xls*"                                                'extension file
    '
    i = 2
    ActiveSheet.Cells.Clear
    rutas.Add ruta
    Call AgregaDir(ruta)
    '
    For Each sd In rutas
        'If InStr(1, sd, wilddir) > 1 Then
            arch = Dir(sd & "\*." & ext)
            Do While arch <> ""
                'If InStr(1, arch, wmatch) > 0 Then
                    If Right(sd, 1) <> "\" Then sd = sd & "\"
                    'Workbooks.Open Filename:=sd & arch, ReadOnly:=True
                    'Do some stuff to the file that's not important right now
                    'ActiveWorkbook.Close savechanges:=False
                    Cells(i, "A").Value = sd
                    Cells(i, "B").Value = arch
                    i = i + 1
                'End If
                arch = Dir()
            Loop
        'End If
    Next
    '
    Set rutas = Nothing
    Application.ScreenUpdating = True
    MsgBox "End", vbInformation, "FILES"
End Sub
'
Sub AgregaDir(lpath)
'Add directorios
    '
    On Error Resume Next
    Dim SubDir As New Collection
    If Right(lpath, 1) <> "\" Then lpath = lpath & "\"
    DirFile = Dir(lpath & "*", vbDirectory)
    Do While DirFile <> "" 'Add subdir to collection
        If DirFile <> "." And DirFile <> ".." Then
            If ((GetAttr(lpath & DirFile) And vbDirectory) = 16) Then
                Cells(i, "A").Value = lpath
                Cells(i, "B").Value = DirFile
                SubDir.Add lpath & DirFile
                Cells(i, "C").Value = Err.Description
                i = i + 1
            End If
        End If
        DirFile = Dir
    Loop
    For Each sd In SubDir
        rutas.Add sd
        Call AgregaDir(sd)
    Next
End Sub

At the end, check column C to see which folder or file has a problem

 

[Gojira]

Hi Dante,

Sorry for the delay in responding. I've run the other macro and it flagged up a couple of files as 'Not Found'. Having renamed them in the file system and rerun the first macro everything now appears to be working as desired, so thank you very much for your help in troubleshooting. I'll keep that macro as a way of problem solving in the future!

 

[DanteAmor]

I'm glad to help you