Insert Images into Excel from sub directories based on cell value - excel

Question

I am a VBA novice but have been able to modify the below code to insert images in my spreadsheet based on cell values as long as the images are in the specific folder. How would I go about changing the code so that it searches all the sub folders within the directory? Any help would be greatly appreciated.
Public Sub Add_Pics_Example()
Dim oCell As Range
Dim oRange As Range
Dim oActive As Worksheet
Dim sPath As String
Dim sFile As String
Dim oShape As Shape
Worksheets("Range").Activate
sPath = "Z:\Pictures\Product Images\"
ActiveSheet.DrawingObjects.Select
Selection.Delete
Set oActive = ActiveSheet
Set oRange = oActive.Range("B4:bz4")
On Error Resume Next
For Each oCell In oRange
sFile = oCell.Value & ".jpg"
Set oShape = oActive.Shapes.AddPicture(sPath & sFile, False, True, _
oCell.Offset(-3, 0).Left + 30, oCell.Offset(-3, 0).Top + 3, 60, 60)
Next oCell
On Error GoTo 0
Application.ScreenUpdating = True
End Sub

Answer 1

Untested but should be pretty close:
Public Sub Add_Pics_Example()
Dim oCell As Range
Dim oRange As Range
Dim wsActive As Worksheet
Dim sFile As String
Dim dictFiles As Object
Set wsActive = Worksheets("Range")
wsActive.DrawingObjects.Delete
'get all the image files first
Set dictFiles = AllFilesbyName("Z:\Pictures\Product Images\", "*.jpg")
For Each oCell In wsActive.Range("B4:BZ4")
sFile = oCell.Value & ".jpg"
'do we have this file ?
If dictFiles.exists(sFile) Then
wsActive.Shapes.AddPicture dictFiles(sFile), False, True, _
oCell.Offset(-3, 0).Left + 30, _
oCell.Offset(-3, 0).Top + 3, 60, 60
End If
Next oCell
End Sub
'starting at startFolder, return a dictionary mapping file names to
' full paths (note doesn't handle >1 file of the same name)
' from startfolder and all subfolders
Function AllFilesbyName(startFolder As String, filePattern As String, _
Optional subFolders As Boolean = True) As Object
Dim fso, fldr, f, subFldr
Dim dictFiles As Object, colSub As New Collection
Set fso = CreateObject("scripting.filesystemobject")
Set dictFiles = CreateObject("scripting.dictionary")
dictFiles.comparemode = 1 'TextCompare: case-insensitive
colSub.Add startFolder
Do While colSub.Count > 0
Set fldr = fso.getfolder(colSub(1))
colSub.Remove 1
For Each f In fldr.Files
If UCase(f.Name) Like UCase(filePattern) Then
'EDIT: fixed the line below
dictFiles(f.Name) = fso.buildpath(fldr.Path, f.Name)
End If
Next f
If subFolders Then
For Each subFldr In fldr.subFolders
colSub.Add subFldr.Path
Next subFldr
End If
Loop
Set AllFilesbyName = dictFiles
End Function