Search in folders/subfolders: Tweaking a previous solution

mpc000

New Member
Joined
Jan 17, 2022
Messages
6
Office Version
  1. 2021
Platform
  1. Windows
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.


Code:
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
 
Last edited by a moderator:

Excel Facts

Save Often
If you start asking yourself if now is a good time to save your Excel workbook, the answer is Yes
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?

Code:
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
 
Upvote 0
Assuming the file names in column A are complete file names, including extension, try this macro:
VBA Code:
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:
VBA Code:
            command = "cmd /c DIR /S /B " & Q(CStr(searchFolders(i) & fileName)) & " > " & Q(CStr(tempFile))
to:
VBA Code:
            command = "cmd /c DIR /S /B " & Q(CStr(searchFolders(i) & "*" & fileName & "*")) & " > " & Q(CStr(tempFile))
 
Upvote 0
Upvote 0
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:
VBA Code:
            command = "cmd /c DIR /S /B " & Q(CStr(searchFolders(i) & fileName)) & " > " & Q(CStr(tempFile))
            WSh.Run command, 0, True
with:
VBA Code:
            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.
 
Upvote 0

Forum statistics

Threads
1,223,911
Messages
6,175,333
Members
452,636
Latest member
laura12345

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top