Search for a match files using value from selected cell in Folder or Subfolders

:hi:
I'm New Here and a novice in vba.
I need help, I have a project in my work that need to check if a file exist from our network file server that have multiple subfolder I'm using selected cells as search reference from my worksheet.
I supposed to search a file or multiple files, but my code only work for selected multiple cells only, I need it to search even if I select only 1 cell, I got error miss match if I do so.

Thanks in advance
Here's the code I'm working with

Code:

---

Sub Search_myFolder_Network()
    Dim myFolder As String
    Dim myRange As Range, colFiles As Collection
    Dim arrNames, arrMsg, r As Long, msg As String, nm, fName
   
    With Application.FileDialog(msoFileDialogFolderPicker)
        .Title = "Select a Folder"
        .InitialFileName = Application.DefaultFilePath & "\"
        If .Show = 0 Then Exit Sub
        myFolder = .SelectedItems(1)
    End With
   
    Set colFiles = AllFileNames(myFolder)
   
    Set myRange = Selection
    arrNames = myRange.Value 'assumes one-column contiguous range is selected
   
    For r = 1 To UBound(arrNames, 1)
        msg = "File not found"  'reset message
        fName = arrNames(r, 1)
        For Each nm In colFiles  'loop over all found file names
            If InStr(1, nm, fName, vbTextCompare) > 0 Then
                msg = "File exists"
                Debug.Print "Found " & fName & " in " & nm
                Exit For  'stop checking
            End If
        Next nm
        arrNames(r, 1) = msg 'replace file name with result message
    Next r
   
    myRange.Offset(0, 1).Value = arrNames  'write the results to the next column


End Sub


'Return a collection of unique file names given a starting folder and a file pattern
'  e.g. "*.txt"
'Pass False for last parameter if don't want to check subfolders
Function AllFileNames(startFolder As String, Optional subFolders As Boolean = True) As Collection
    Dim fso, fldr, f, subFldr, fpath
    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
        If subFolders Then
            For Each subFldr In fldr.subFolders
                colSub.Add subFldr.Path
            Next subFldr
        End If
        fpath = fldr.Path
        If Right(fpath, 1) <> "\" Then fpath = fpath & "\"
        f = Dir(fpath & "*.*") 'Dir is faster...
        Do While Len(f) > 0
            On Error Resume Next 'ignore error if key is already added
            colFiles.Add f, f
            On Error GoTo 0      'stop ignoring errors
            f = Dir()
        Loop
    Loop
    Set AllFileNames = colFiles
End Function

---

try:

Code:

---

Sub Search_myFolder_Network()
    Dim myFolder As String
    Dim myRange As Range, colFiles As New Collection
    Dim arrNames() As Variant, arrMsg, r As Long, msg As String, nm, fName
    Dim cel As Range
    With Application.FileDialog(msoFileDialogFolderPicker)
        .Title = "Select a Folder"
        .InitialFileName = Application.DefaultFilePath & "\"
        If .Show = 0 Then Exit Sub
        myFolder = .SelectedItems(1)
    End With
   
   
    Call RecursiveDir(colFiles, myFolder, "*.*", True)
   
    ReDim arrNames(1 To colFiles.Count)
   
    Set myRange = Application.Selection
    'arrNames = myRange 'assumes one-column contiguous range is selected
   
    If IsEmpty(myRange) Then
        Debug.Print "Empty"
        Exit Sub
    End If
   
    For Each cel In myRange
        r = r + 1
    'For r = 0 To UBound(arrNames, 1)
        msg = "File not found"  'reset message
        'fName = arrNames(r, 1)
        fName = cel & ""
        If Len(fName) <> 0 Then
            For Each nm In colFiles  'loop over all found file names
                If InStr(1, nm, fName, vbTextCompare) > 0 Then
                    'msg = "File exists"
                    msg = "Found " & fName & " in " & Replace$(nm, fName, "")
                    Debug.Print msg
                    Exit For  'stop checking
                End If
            Next nm
            arrNames(r) = msg 'replace file name with result message
        End If
    Next cel
   
    myRange.Offset(0, 1).Value = arrNames  'write the results to the next column




End Sub


' arnelgp
Public Sub RecursiveDir(ByRef colFiles As Collection, _
                            ByVal strFolder As String, _
                            ByVal strFileSpec As String, _
                            Optional ByVal bIncludeSubfolders As Boolean = False)


    Dim strTemp As String
    Dim colFolders As New Collection
    Dim vFolderName As Variant


    On Error Resume Next
    'Add files in strFolder matching strFileSpec to colFiles
    strFolder = TrailingSlash(strFolder)
    strTemp = Dir(strFolder & strFileSpec)
    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)
        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 Sub




Private 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

---

Hi Thank you very much for your quick response, I have tested your code just now, I really appreciate your new input with my code - the printing of path and file name with the result, but unfortunately when I'm searching (selecting) multiple cells the printed results are all the same; it seems the result for 1st selected cell is being copied to the rest of the selection so it seems like it only search the 1st cell in the selection. And is there a way to print the result in separate column, like for example column C (file name to be search);next column- result if Found or not; then next column the file path only and next the full file name.
I know this is too much, thanks you in advance

it would be best to show me your worksheet.
and whatever filename you have on it, i will
try to replicate it locally.

＞so it seems like it only search the 1st cell in the selection

myRange.Offset(0, 1).Value = Application.Transpose(arrNames)

This code is sufficient:

Code:

---

Sub M_snb()
  With Application.FileDialog(4)
    .InitialFileName = Application.DefaultFilePath & "\"
    If .Show Then c00 = .SelectedItems(1)
  End With
   
  With CreateObject("wscript.shell")
    For Each it In Selection
      c01 = c01 & vbLf & .exec("cmd /c dir """ & c00 & "\*" & it & """*.* /b /s").stdout.readall
    Next
  End With
   
  MsgBox c01
End Sub

---

Code:

---

Option Explicit


Sub test()
    Dim dic As Object
    Dim fdg As FileDialog, p As String
    Dim cmd As String, s, k As Long
    Dim fn As String
    Dim c As Range, msg As String
   
    Set fdg = Application.FileDialog(msoFileDialogFolderPicker)
    If Not fdg.Show Then Exit Sub
    p = fdg.SelectedItems(1) & "\"
   
    Set dic = CreateObject("scripting.dictionary")
   
    cmd = "cmd /c dir """ & p & "*.*"" /b/s/a-d"
    s = Split(CreateObject("wscript.shell").exec(cmd).stdout.readall, vbCrLf)
    For k = 0 To UBound(s) - 1
        fn = Dir(s(k))
        dic(fn) = dic(fn) & " , " & Left(s(k), InStrRev(s(k), "\") - 1)
    Next
   
    For Each c In Selection
        fn = c.Value
        If dic.exists(fn) Then
            msg = "Found in " & Mid(dic(fn), 3)
        Else
            msg = "not found"
        End If
        c.Offset(, 1).Value = msg
    Next


End Sub

---

Code:

---

Option Explicit


Sub test2()
    Dim dic As Object
    Dim fdg As FileDialog, p As String
    Dim cmd As String, s, k As Long
    Dim fn As String
    Dim c As Range, msg As String
   
    Set fdg = Application.FileDialog(msoFileDialogFolderPicker)
    If Not fdg.Show Then Exit Sub
    p = fdg.SelectedItems(1) & "\"
   
    Set dic = CreateObject("scripting.dictionary")
   
    cmd = "cmd /c dir """ & p & "*.*"" /b/s/a-d"
    s = Split(CreateObject("wscript.shell").exec(cmd).stdout.readall, vbCrLf)
    For k = 0 To UBound(s) - 1
        fn = Dir(s(k))
        dic(fn) = dic(fn) & " , " & s(k)
    Next
 
    For Each c In Selection
        fn = c.Value
        s = Filter(dic.keys, fn)
        msg = ""
        If UBound(s) > -1 Then
            For k = 0 To UBound(s)
                msg = msg & dic(s(k))
            Next
            msg = "Found in " & Mid(msg, 3)
        Else
            msg = "not found"
        End If
        c.Offset(, 1).Value = msg
    Next


End Sub

---

@mana

the /s option shows the fullname of every file.
You don't need any Dir, nor a Dictionary.

oh! just a waste of time!! :doh:

Hi Mana and arnelgp,
Thanks for your suggestion, I change the code with this "myRange.Offset(0, 1).Value = Application.Transpose(arrNames)" and it works, I just use excel formula to separate the string to individual column.

The issue is it takes longer to search and print the result.

Attachment 30232
Attachment 30233

I noticed that when I'm trying to search from 1 single folder directory it load fast but when the directory contains multiple subfolders it took me 3 mins to search 25 file.
But for now I'll make used of it as long as it works.

Thanks you all so much for your time and assistance.