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