VBA to find multiple files - vba

Question

I have this code which finds file names(along with file paths) based on search string.This code works fine in finding single files. I would like this macro to find multiple files and get their names displayed separated using a comma.
Function FindFiles(path As String, SearchStr As String)
Dim FileName As String ' Walking filename variable.
Dim DirName As String ' SubDirectory Name.
Dim dirNames() As String ' Buffer for directory name entries.
Dim nDir As Integer ' Number of directories in this path.
Dim i As Integer ' For-loop counter.
Dim Name As String
Dim Annex As String
On Error GoTo sysFileERR
If Right(path, 1) <> "\" Then path = path & "\"
' Search for subdirectories.
nDir = 0
ReDim dirNames(nDir)
DirName = Dir(path, vbDirectory Or vbHidden Or vbArchive Or vbReadOnly _
Or vbSystem) ' Even if hidden, and so on.
Do While Len(DirName) > 0
' Ignore the current and encompassing directories.
If (DirName <> ".") And (DirName <> "..") Then
' Check for directory with bitwise comparison.
If GetAttr(path & DirName) And vbDirectory Then
dirNames(nDir) = DirName
DirCount = DirCount + 1
nDir = nDir + 1
ReDim Preserve dirNames(nDir)
'List2.AddItem path & DirName ' Uncomment to list
End If ' directories.
sysFileERRCont:
End If
DirName = Dir() ' Get next subdirectory.
Loop
' Search through this directory and sum file sizes.
FileName = Dir(path & SearchStr, vbNormal Or vbHidden Or vbSystem _
Or vbReadOnly Or vbArchive)
'Sheet1.Range("C1").Value2 = path & "\" & FileName
While Len(FileName) <> 0
FindFiles = path & "\" & FileName
FileCount = FileCount + 1
' Load List box
' Sheet1.Range("A1").Value2 = path & FileName & vbTab & _
FileDateTime(path & FileName) ' Include Modified Date
FileName = Dir() ' Get next file.
Wend
' If there are sub-directories..
If nDir > 0 Then
' Recursively walk into them
For i = 0 To nDir - 1
FindFiles = path & "\" & FileName
Next i
End If
AbortFunction:
Exit Function
sysFileERR:
If Right(DirName, 4) = ".sys" Then
Resume sysFileERRCont ' Known issue with pagefile.sys
Else
MsgBox "Error: " & Err.Number & " - " & Err.Description, , _
"Unexpected Error"
Resume AbortFunction
End If
End Function
Sub Find_Files()
Dim SearchPath As String, FindStr As String, SearchPath1 As String
Dim FileSize As Long
Dim NumFiles As Integer, NumDirs As Integer
Dim Filenames As String, Filenames1 As String
Dim r As Range
'Screen.MousePointer = vbHourglass
'List2.Clear
For Each cell In Range("SS")
SearchPath = Sheet3.Range("B2").Value2
SearchPath1 = Sheet3.Range("B3").Value2
FindStr = Cells(cell.Row, "H").Value
Filenames = FindFiles(SearchPath, FindStr)
Filenames1 = FindFiles(SearchPath1, FindStr)
'Sheet1.Range("B1").Value2 = NumFiles & " Files found in " & NumDirs + 1 & _
" Directories"
Cells(cell.Row, "F").Value = Filenames
Cells(cell.Row, "G").Value = Filenames1
'Format(FileSize, "#,###,###,##0") & " Bytes"
'Screen.MousePointer = vbDefault
Next cell
End Sub
Any thoughts will be highly appreciated.

Answer 1

I realize this question is very old, but it is unanswered. Here is a quick method for finding multiple files and their paths. VBA's DIR function isn't really very handy, but CMD's DIR function is well optimized and has a plethora of command line switches to make it return only files (or even just folders) that match your criteria. The trick is to call DIRfrom a WScript shell so that the output can be parsed by VBA.
For example, this snippet of code will find every file on your system that starts with config.
Dim oShell As Object 'New WshShell if you want early binding
Dim cmd As Object 'WshExec if you want early binding
Dim x As Integer
Const WshRunning = 0
Set oShell = CreateObject("Wscript.Shell")
Set cmd = oShell.Exec("cmd /c ""Dir c:\config* /a:-d /b /d /s""")
Do While cmd.Status = WshRunning
DoEvents
Loop
Debug.Print cmd.StdOut.ReadAll
Set oShell = Nothing
Set cmd = Nothing