Search in folders/subfolders: Tweaking a previous solution

[mpc000]

In a previous request by MM91 for how to search for a pdf in folders _and_ subfolders, @DanteAmor provided the solution below. I'm trying to adapt it to do something slightly different, specifically:

I got column A which lists a number of filenames (the number of rows changes, so it'll have to find the last cell every time).
I want to prompt the user to select a folder (which the code below does), and then search all the folders AND subfolders, and if it finds the file listed in column A to output the path in column B.

It'd be a bonus if it's possible to select multiple folders at the prompt (e.g. across different harddrives) to check them all.

e.g.
Column A
filenameA
filenameB
filenameC
...
FilenameX

Column B should output something like:
C:\folderA\exampleB\
C:\folderA\exampleB\
D:\folderC\example\
...

You get the idea.

Any help or pointers will be much appreciated.

Option Explicit

Dim xfolders As New Collection

Private Sub CommandButton1_Click()
  Dim arch As Variant, xfold As Variant
  Dim sPath As String
 
  If UserPartNumberInput.Value = "" Then
    MsgBox "Enter part number"
    UserPartNumberInput.SetFocus
    Exit Sub
  End If
 
  With Application
    .DisplayAlerts = False
    .ScreenUpdating = False
    With .FileDialog(msoFileDialogFolderPicker)
      .Title = "Select the initial folder"
      If .Show <> -1 Then Exit Sub
      sPath = .SelectedItems(1) & "\"
    End With
  End With
 
  xfolders.Add sPath
  Call AddSubDir(sPath)
 
  For Each xfold In xfolders
    arch = Dir(xfold & "\" & Left(UserPartNumberInput.Value, 4) & "*.pdf")
    Do While arch <> ""
      ActiveWorkbook.FollowHyperlink xfold & "\" & arch
      Exit Do
      arch = Dir()
    Loop
  Next
End Sub
'
Sub AddSubDir(lPath As Variant)
  Dim SubDir As New Collection, DirFile As Variant, sd As Variant
  If Right(lPath, 1) <> "\" Then lPath = lPath & "\"
  DirFile = Dir(lPath & "*", vbDirectory)
  Do While DirFile <> ""
    If DirFile <> "." And DirFile <> ".." Then
      If ((GetAttr(lPath & DirFile) And vbDirectory) = 16) Then
        SubDir.Add lPath & DirFile
      End If
    End If
    DirFile = Dir
  Loop
  For Each sd In SubDir
    xfolders.Add sd
    Call AddSubDir(sd)
  Next
End Sub

 

[mpc000]

I've tried modifying the above to be called by a macro instead of a userform, and to work for the filename on cell A2 (and then I'll try to figure out the rest, as long as I can get it working for one cell).

However, I get an error with 'Object required' at the:
xfolders.Add sd

command. Any ideas?

Sub HashV()


Dim xfolders As New Collection


  Dim arch As Variant, xfold As Variant
  Dim sPath As String
  
  With Application
    .DisplayAlerts = False
    .ScreenUpdating = False
    With .FileDialog(msoFileDialogFolderPicker)
      .Title = "Select the initial folder"
      If .Show <> -1 Then Exit Sub
      sPath = .SelectedItems(1) & "\"
    End With
  End With
  
  xfolders.Add sPath
  Call AddSubDir(sPath)
  
  For Each xfold In xfolders
    arch = Dir(xfold & "\" & A2)

    Do While arch <> ""
      ActiveWorkbook.FollowHyperlink xfold & "\" & arch
      Exit Do
      arch = Dir()
    Loop
  Next
End Sub

Sub AddSubDir(lPath As Variant)
  Dim SubDir As New Collection, DirFile As Variant, sd As Variant
  If Right(lPath, 1) <> "\" Then lPath = lPath & "\"
  DirFile = Dir(lPath & "*", vbDirectory)
  Do While DirFile <> ""
    If DirFile <> "." And DirFile <> ".." Then
      If ((GetAttr(lPath & DirFile) And vbDirectory) = 16) Then
        SubDir.Add lPath & DirFile
      End If
    End If
    DirFile = Dir
  Loop
  For Each sd In SubDir
    xfolders.Add sd
    Call AddSubDir(sd)
  Next
End Sub

 

[John_w]

Assuming the file names in column A are complete file names, including extension, try this macro:

Option Explicit

Public Sub Find_Files()

    Dim searchFolders() As String, searchFoldersCount As Long
    Dim showOK As Boolean
    Dim fileNames As Range, fileName As Range
    Dim WSh As Object 'WshShell
    Dim FSO As Object 'Scripting.FileSystemObject
    Dim ts As Object 'Scripting.TextStream
    Dim tempFile As String
    Dim command As String
    Dim folderFiles As Variant
    Dim foundFolder As String
    Dim i As Long
   
    With Application.FileDialog(msoFileDialogFolderPicker)
        searchFoldersCount = 0
        Do
            .Title = "Select search folder " & searchFoldersCount + 1 & " or click Cancel to " & IIf(searchFoldersCount + 1 = 1, "exit macro", "start searching")
            showOK = .Show
            If showOK Then
                ReDim Preserve searchFolders(0 To searchFoldersCount)
                searchFolders(searchFoldersCount) = .SelectedItems(1) & "\"
                searchFoldersCount = searchFoldersCount + 1
            End If
        Loop Until Not showOK
    End With
    If searchFoldersCount = 0 Then Exit Sub
   
    With ActiveWorkbook.Worksheets(1)
        Set fileNames = .Range("A2", .Cells(Rows.Count, "A").End(xlUp))
    End With

    Set WSh = CreateObject("WScript.Shell") 'New WshShell
    Set FSO = CreateObject("Scripting.FileSystemObject") 'New Scripting.FileSystemObject

    tempFile = Environ$("temp") & "\dir.txt"
   
    For Each fileName In fileNames
       
        foundFolder = ""
        i = 0
        While i < searchFoldersCount And foundFolder = ""
            command = "cmd /c DIR /S /B " & Q(CStr(searchFolders(i) & fileName)) & " > " & Q(CStr(tempFile))
            WSh.Run command, 0, True
           
            Set ts = FSO.OpenTextFile(tempFile)
            If Not ts.AtEndOfStream Then
                folderFiles = Split(ts.ReadAll, vbCrLf)
                foundFolder = Left(folderFiles(0), InStrRev(folderFiles(0), "\"))
            End If
            ts.Close
           
            i = i + 1
        Wend
       
        If foundFolder <> "" Then
            fileName.Offset(0, 1).Value = foundFolder
        Else
            fileName.Offset(0, 1).Value = "NOT FOUND"
        End If
       
    Next
   
    Kill tempFile
      
End Sub


Private Function Q(text As String) As String
    Q = Chr(34) & text & Chr(34)
End Function

If they are partial file names, with or without file extension, change this line:

            command = "cmd /c DIR /S /B " & Q(CStr(searchFolders(i) & fileName)) & " > " & Q(CStr(tempFile))

to:

            command = "cmd /c DIR /S /B " & Q(CStr(searchFolders(i) & "*" & fileName & "*")) & " > " & Q(CStr(tempFile))

 

[mpc000]

Thank you very much. Unfortunately it doesn't seem to find the files, so it outputs nothing.

Another macro I tweaked to achieve the end goal (albeit without the ability to select multiple folders as your solution) seems to work
Post here: Macro to cycle through column A and output in column B. Need small correction to finish it.

Any suggestions why your code isn't picking any files?

 

[John_w]

Thank you very much. Unfortunately it doesn't seem to find the files, so it outputs nothing.

Probably because the DIR command isn't working, maybe due to access rights. Replace these 2 lines:

            command = "cmd /c DIR /S /B " & Q(CStr(searchFolders(i) & fileName)) & " > " & Q(CStr(tempFile))
            WSh.Run command, 0, True

with:

            command = "cmd /k DIR /S /B " & Q(CStr(searchFolders(i) & fileName)) & " > " & Q(CStr(tempFile))
            WSh.Run command, 1, True

Run the macro from the VBA editor and it should open a command window. Please post the contents of the command window. Stop the macro from the VBA editor and click X on the command window to close it.