Search file name from folder and Subfolder if Exist or not-CodePudding

I've been working on a code and can't seem to find a way to make this work, here it goes: I'll have column A with value that I will select cell to search a match on our network folder/subfolder if it exist or not then on next column if the value exist on the folder it will write File Exist.

My code that currently work only search on Main selected Folder only and not including subfolder.

Sub Search_myFolder_Network()
    Dim myFolder As String
    Dim myFileName As String
    Dim myRange As Range
    Dim myCell As Range
    
    With Application.FileDialog(msoFileDialogFolderPicker)
        .Title = "Select a Folder"
        .InitialFileName = Application.DefaultFilePath & "\"
        If .Show = 0 Then Exit Sub
        myFolder = .SelectedItems(1)
    End With
    
    Set myRange = Selection
    
    For Each myCell In myRange
        myFileName = myCell.Value
        If Dir(myFolder & "\" & "*" & myFileName & "*") = "" Then
            myCell.Offset(0, 1) = "File Doesn't Exists."
        Else
            myCell.Offset(0, 1) = "File Exists"
        End If
    Next myCell
End Sub

CodePudding user response：

Try this out: comments inline

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