VBA search for specific file name in folders and their subfolders

[Milen]

Hey everyone,

I feel like I have a relatively simple challenge, but for the life of me can't figure out the solution myself.

I have often excel lists with product names in column A. I have two folders with several subfolders (and sub-subfolders) containing images of products. File names are identical to the product names i have.
I have a big macro that (among other things) searches through the two main folders, and if it finds image matching each product name - it inserts image next to it. if it doesn't find relevant image, the macro enters "no image found" on the line instead. So far so good.

My challenge is I can't get it to also look into the subfolders. Folder_location1 and Folder_location2 both have many subfolders, and even sub-subfolders.

I have in the macro defined the two main folders - "pic_folder" and "alt_pic_folder". Isn't there a way to make these two paths also include all their respective subfolders?
To keep the macro brief I've cut it down to what I believe is the relevant part for this question - the defining of "pic_folder" and "alt_pic_folder", and the way I've made the macro go through them to check for images.

Is my wish doable at all, or is some heavy macro modification required? Please help.

Sub select_file_add_pictures()

Dim lastCell, i As Long
Dim pic_folder$, alt_pic_folder$, fso, mypic As Object
Dim xPic As Picture
Dim Ws As Worksheet
Dim r As Long, Ppos As Long, m As Long
Dim shp As Shape
Dim Pic As Picture


user = Environ("username")

pic_folder = "C:\users\" & user & "\Folder_location1\"
alt_pic_folder = "C:\users\" & user & "\Folder_location2\"

'code to select the a file - removed to keep this short

Set Ws = ActiveSheet

'search for item photos
i = 1
lastCell = ActiveSheet.Range("A" & Rows.Count).End(xlUp).Row
For cell = 3 To lastCell Step 1
itemno = ActiveSheet.Range("A" & cell).Value

Filename = Dir(pic_folder$ & itemno & "." & "*")

If Filename = "" Then GoTo Line1 Else Filename = pic_folder & Filename    'extra line to check the file path - in case error is suspected
    'ActiveSheet.Range("A" & cell).Offset(0, 1).Value = Filename

GoTo InsertPicture

Line1:
    Filename = Dir(alt_pic_folder$ & itemno & "-" & "*" & "-" & "1." & "*")
    If Filename = "" Then GoTo Line2 Else Filename = alt_pic_folder & Filename
    'extra line to check the file path - in case error is suspected
   
    GoTo InsertPicture

Line2:
    ActiveSheet.Range("A" & cell).Offset(0, 1).Value = "No picture found"
    GoTo Nextline
    
InsertPicture:

Set mypic = ActiveSheet.Shapes.AddPicture(fileName, False, True, 20, 20, -1, -1)
'insert-picture code here

Nextline:
i = i + 1
Next

 

End Sub

 

[LydMix]

Look here: Dir function (Visual Basic for Applications)
It says:
You must specify pathname the first time you call the Dir function, or an error occurs. If you also specify file attributes, pathname must be included.

Dir returns the first file name that matches pathname. To get any additional file names that match pathname, call Dir again with no arguments. When no more file names match, Dir returns a zero-length string (""). After a zero-length string is returned, you must specify pathname in subsequent calls, or an error occurs.

You can change to a new pathname without retrieving all of the file names that match the current pathname. However, you can't call the Dir function recursively. Calling Dir with the vbDirectory attribute does not continually return subdirectories.

 

[Candyman8019]

I'm sure there's a direct way to do this, but you could use the following to list files and paths in another sheet, then populate your picture based on a lookup in those results. When you run ListAllFiles, it will open a dialog box where you select your first folder.

Private Sub ListAllFiles()

 Set oFSO = CreateObject("Scripting.FileSystemObject")
 With Application.FileDialog(4)
   If .Show = 0 Then Exit Sub
   GetFiles .SelectedItems(1)
   If x Then Cells(3, 1).Resize(x) = ar
   Erase ar: x = 0
 End With
End Sub

Sub GetFiles(xFold)
 Dim Obj As Object
 If Right(xFold, 1) <> "\" Then xFold = xFold & "\"
 With oFSO.Getfolder(xFold)
    For Each Obj In .Files
       ar(x, 0) = Obj.Path 'obj.name
       x = x + 1
    Next
    For Each Obj In .SubFolders
       GetFiles xFold & Obj.Name
    Next
 End With
End Sub

 

[Milen]

I'm sure there's a direct way to do this, but you could use the following to list files and paths in another sheet, then populate your picture based on a lookup in those results. When you run ListAllFiles, it will open a dialog box where you select your first folder.

Private Sub ListAllFiles()

 Set oFSO = CreateObject("Scripting.FileSystemObject")
 With Application.FileDialog(4)
   If .Show = 0 Then Exit Sub
   GetFiles .SelectedItems(1)
   If x Then Cells(3, 1).Resize(x) = ar
   Erase ar: x = 0
 End With
End Sub

Sub GetFiles(xFold)
 Dim Obj As Object
 If Right(xFold, 1) <> "\" Then xFold = xFold & "\"
 With oFSO.Getfolder(xFold)
    For Each Obj In .Files
       ar(x, 0) = Obj.Path 'obj.name
       x = x + 1
    Next
    For Each Obj In .SubFolders
       GetFiles xFold & Obj.Name
    Next
 End With
End Sub

Hey Joe,
Thank you for the suggestion. I seem to be getting "compile error: Sub or Function not defined". Seems to be referring to the below line:

 ar(x, 0) = Obj.Path 'obj.name

I'm not experienced enough with VBA to understand the error and how to fix it myself . Can you please help?

 

[Milen]

Look here: Dir function (Visual Basic for Applications)
It says:
You must specify pathname the first time you call the Dir function, or an error occurs. If you also specify file attributes, pathname must be included.

Dir returns the first file name that matches pathname. To get any additional file names that match pathname, call Dir again with no arguments. When no more file names match, Dir returns a zero-length string (""). After a zero-length string is returned, you must specify pathname in subsequent calls, or an error occurs.

You can change to a new pathname without retrieving all of the file names that match the current pathname. However, you can't call the Dir function recursively. Calling Dir with the vbDirectory attribute does not continually return subdirectories.

Hey mate,

Thank you for the reply. Not sure I 100% understand what you're saying, but sounds like you're saying VBA can't do what I'm trying to make it do. Is that correctly understood?
You wrote "To get any additional file names that match pathname, call Dir again with no arguments" . Sorry, but not sure I follow why I'd want to get additional file names that match pathname? .
To boil it down, I want the macro to look through the files in folder "folder_location1". If it finds no matches, I'd like it to look through "folder_location1\subfolder1". If no matches there either, look through "folder_location1\subfolder2", and so on - until match is found. Surely every new subfolder is a new pathname?

 

[Candyman8019]

Looks like you may need to add an object library reference. Go into the VB editor. Tools | References.

 

[Milen]

Looks like you may need to add an object library reference. Go into the VB editor. Tools | References.

View attachment 105913

Hey Joe,

Thanks for the reply. Unfortunately it didn't seem to do much. I now have the same references in same order as yours, but still get the same error. I can choose the folder from he ListAllFiles, but get the below error immediately after.

 

[Candyman8019]

My apologies, place this line at the top...before any subs:

Dim oFSO As Object, ar(2000, 0), x As Long