CODEWITHSUNDEEP
excelvbasubdirectory
mickael
mickael

Reputation: 73

Add a folder name filter to a recursive DIR search

I need help on implementing a filter to accelerate a file search using DIR function in VBA.

Context : I have a folder of contracts. Some contracts are directly on it, some are in separate "category" sub folders. So it looks like this : Folder architecture

On each contract folder, I need to find a file, whose name contains "RENS_RES", located in "2000*\2300*\". And I need to get the path to that file

Situation : The function works. But it is slow, because everything is on a server, and there are a lot of folders/subfolders/files to go through, and it tests them all. It can take up to 15 minutes.

So I want to make it faster.

Right now, I have a code that looks like this :

Dim fso 'As New FileSystemObject
Dim fld 'As Folder
Public tampon(120) As Variant 'Where I stock my selected files path
sFol = "C:\something\" The path to my main folder, that contains everything, created as String
sFile = "*RENS_RES*.xlsx" 'The criteria to determine the files to select, created as String
Function FindFile(ByVal sFol As String, sFile As String) As String 'Arguments initially from somewhere else specified
'initially called somewhere else

 Dim tFld, tFil as String 'The currently selected folder and file
 Dim FileName As String  'FileName the name of the selected file

 Set fso = CreateObject("Scripting.FileSystemObject")
 Set fld = fso.GetFolder(sFol)
 FileName = Dir(fso.BuildPath(fld.path, sFile), vbNormal Or _
              vbHidden Or vbSystem Or vbReadOnly) 'I search the first file respecting the criteria sFile
 While Len(FileName) <> 0 'I keep going until all files int he folder are tested
  FindFile = FindFile + FileLen(fso.BuildPath(fld.path, _
  FileName))
  tampon(i) = fso.BuildPath(fld.path, FileName) 'We save the value
  i = i + 1
  FileName = Dir()  ' Get next file
  DoEvents
 Wend

 If fld.SubFolders.Count > 0 Then 'If the current folder has subfolders
  For Each tFld In fld.SubFolders 'We consider each subfolder
    If Not (tFld.Name Like "#000*") Or tFld.Name Like "2000*" Or tFld.Name Like "2300*" Then ' We exclude all the subfolders that start with 4 numbers (format x000) and are not 2000 or 2300 from the search
        DoEvents
        FindFile = FindFile + FindFile(tFld.path, sFile) 'We call again the function to test all files in that subfolder
    End If
  Next
 End If
 Exit Function
Catch:  FileName = ""
   Resume Next
End Function

I have tried to put a filter on the subfolder selection :

If Not (tFld.Name Like "#000*") Or tFld.Name Like "2000*" Or tFld.Name Like "2300*" Then

It has inverted logic because to simulate an exit for in the "for each loop".

In theory it should not enter the "if" if the name begins by 4 digits (a number followed by three zeros and is not "2000*" or "2300*" (the two folders we want to go in). I have this because there is no logic in the category or contract name that I could use on the filter.

But the filter does not work : it keeps going through every folder, and I don't understant why. That's where I'm asking for help.

Or would there be another way to do that search that would be faster ?

Thank you in advance for your help, hope I formatted the code decently

Upvotes: 1

Views: 631

Answers (1)

Tim Williams
Tim Williams

Reputation: 166156

If find this this non-recursive approach for finding matches easier to reason about/modify:

'Return a collection of file objects given a starting folder and a file pattern
'  e.g. "*.txt"
'Pass False for last parameter if don't want to check subfolders
Function GetMatches(startFolder As String, filePattern As String, _
                    Optional subFolders As Boolean = True) As Collection

    Dim fso, fldr, f, subFldr
    Dim colFiles As New Collection
    Dim colSub As New Collection

    Set fso = CreateObject("scripting.filesystemobject")
    colSub.Add startFolder

    Do While colSub.Count > 0

        Set fldr = fso.getfolder(colSub(1))
        colSub.Remove 1

        For Each f In fldr.Files
            'check filename pattern
            If UCase(f.Name) Like UCase(filePattern) Then colFiles.Add f
        Next f

        If subFolders Then
            For Each subFldr In fldr.subFolders
                'check subfolder criteria
                'another attempt at your logic...
                If subFldr.Name Like "2000*" or Not subFldr.Name Like "#000*" Then
                    colSub.Add subFldr.Path
                End If
            Next subFldr
        End If

    Loop

    Set GetMatches = colFiles

End Function

Example usage:

Dim colFiles as Collection
Set colFiles = GetMatches("C:\something\", ""*RENS_RES*.xlsx"")

Upvotes: 1

Related Questions