Insert Images into Excel from sub directories based on cell value

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