Consulting

Results 1 to 11 of 11

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

  1. #1

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


    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
    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

  2. #2
    try:
    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

  3. #3
    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

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

  5. #5
    VBAX Expert
    Joined
    Sep 2016
    Posts
    788
    Location
    >so it seems like it only search the 1st cell in the selection

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




  6. #6
    Knowledge Base Approver VBAX Wizard
    Joined
    Apr 2012
    Posts
    5,635
    This code is sufficient:

    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

  7. #7
    VBAX Expert
    Joined
    Sep 2016
    Posts
    788
    Location
    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

  8. #8
    VBAX Expert
    Joined
    Sep 2016
    Posts
    788
    Location
    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

  9. #9
    Knowledge Base Approver VBAX Wizard
    Joined
    Apr 2012
    Posts
    5,635
    @mana

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

  10. #10
    VBAX Expert
    Joined
    Sep 2016
    Posts
    788
    Location
    oh! just a waste of time!!

  11. #11
    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.

    Annotation 2022-10-12 162647.jpg
    Annotation 2022-10-12 162646.jpg

    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.
    Last edited by ZerP; 10-12-2022 at 02:07 AM.

Tags for this Thread

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •