未经测试，但应该很接近：

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,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