Excel VBA + Generate List of full file names given file base names (or similiar)

Question

I need to search the file system (a drive usually) for a fully defined file path while given only a fragment of the file name.

The fragment is actually the part number of the part, and the files to search are all of type '.idw'. Further, they are named with a series that helps sort them; ie 1XX-XXXX.idw, 2XX-XXX.idw.

There are 50,000+ files and just using a FileScriptingObject and recursive reading each folder then comparing them takes something like 2 minutes per search.

(Given a list of part numbers, I need to populate a column in Excel with the full file name)

I'm guessing my best way to go about this is to generate an indexed list of all of the idw files I'm looking for, reducing the full file string to only the base name and using that as the key. However, this would still required the timely run at the start of each search assuming I use this dictionary/collection/list over and over per run.

Is there any way to store a dictionary in an external file, so I can generate the indexed list once per day or a lot less frequently?

Otherwise, is there a better way to do this with VBA that I have not thought of?

Answer 1

Following up the comment from @omegastripes, you can combine three methods to achieve the objective.

1. Use the Exec method of WScript.Shell to run a Dir command - likely faster than using FileSystemObject
2. Split the StdOut to get a Variant array of all the filenames returned - this is the one-time hit to get the list of files you want to search over
3. Use the Filter function to reduce the array to just the filenames including the ones you are interested in displaying on the spreadsheet.

The DIR command leverages some switches that are important to the task:

• /S - recursive through sub-directories
• /B - bare names only
• /A:-D - exclude directories from output, i.e. files only

Here's the sample code:

Option Explicit

Sub Test()

    Dim arrFiles As Variant
    Dim arrSearchTerms As Variant
    Dim arrMatches As Variant
    Dim intTargetCounter As Integer
    Dim intMatchCounter As Integer

    'get files
    arrFiles = GetFileList("C:\WINDOWS", "idw")
    If UBound(arrFiles) = 0 Then
        MsgBox "No files found"
        Exit Sub
    End If

    'iterate search terms and check collection
    arrSearchTerms = Array("1XX-XXXX", "2XX-XXXX")
    For intTargetCounter = LBound(arrSearchTerms) To UBound(arrSearchTerms)
        arrMatches = Filter(arrFiles, arrSearchTerms(intTargetCounter))
        For intMatchCounter = LBound(arrMatches) To UBound(arrMatches)
            Debug.Print arrMatches(intMatchCounter)
        Next intMatchCounter
    Next intTargetCounter

End Sub

Function GetFileList(strRoot As String, strExtensionFilter As String) As Variant

    Dim objShell As Object
    Dim strCommand As String
    Dim objShellExe As Object

    On Error GoTo CleanUp

    'call cmd
    Set objShell = CreateObject("WScript.Shell")
    strCommand = "%COMSPEC% /C DIR /S /B /A:-D *." & strExtensionFilter
    objShell.CurrentDirectory = strRoot
    Set objShellExe = objShell.Exec(strCommand)

    'wait for listing
    While objShellExe.Status <> 1
        DoEvents
    Wend

    'convert std out to array
    GetFileList = Split(objShellExe.StdOut.ReadAll, vbCrLf)

CleanUp:
    If Err.Number <> 0 Then
        Debug.Print Err.Number & ": " & Err.Description
    End If
    Set objShellExe = Nothing
    Set objShell = Nothing

End Function