Option Explicit
Dim sl

Sub Макрос1()
    Dim r, lr, m, k, pat, i, f
    Dim myPic As Shape
    Dim fso As Object
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set sl = CreateObject("Scripting.Dictionary")
    pat = ActiveWorkbook.Path
    Search fso.GetFolder(pat)
    k = sl.keys
    With ActiveSheet
        lr = Cells(Rows.Count, 25).End(xlUp).Row
        m = .Cells(4, 24).Resize(lr - 3, 2).Value
        Dim rw&, co&
        For rw = 42 To 51 Step 3
        For co = 6 To 10 Step 1
        For r = 1 To UBound(m)
            If InStr(Cells(rw, co), m(r, 1)) > 0 Then
                For i = 0 To UBound(k)
                    If InStr(1, k(i), m(r, 2), vbTextCompare) > 0 Then
                        pat = sl(k(i))
                        With .Cells(rw, co)
                            Set myPic = ActiveSheet.Shapes.AddPicture( _
                    Filename:=pat, _
                    linktofile:=msoFalse, _
                    savewithdocument:=msoCTrue, _
                    Left:=.Offset(0, 0).Left + 1, _
                    Top:=.Offset(0, -1).Top + 1, _
                    Width:=.Offset(0, -1).Width - 2, _
                    Height:=.Offset(0, -1).Height * 3 - 2)
                            myPic.LockAspectRatio = msoFalse
                        End With
                    End If
                Next i
            End If
        Next r
        Next co
        Next rw
    End With
End Sub

Function Search(Fold As Object)
Dim SubFold As Object, Fil As Object

   For Each SubFold In Fold.SubFolders
     Search SubFold
   Next SubFold
   For Each Fil In Fold.Files
        If InStr(1, Fil.Name, ".png", vbTextCompare) > 0 Then
        sl(Fil.Name) = Fil.Path
        End If
   Next Fil
End Function