Public Sub InsPict()
    Dim arr, fldPath$, art$, fName$, i&, r0, lrow&, oDic As Object, IShape As Shape, Zm
    Set oDic = CreateObject("Scripting.Dictionary")
    r0 = 4
    lrow = Cells(Rows.Count, 3).End(xlUp).Row
    arr = Cells(r0, 3).Resize(lrow - r0 + 1).Value
    For i = 1 To UBound(arr)
        oDic(arr(i, 1)) = i + r0 - 1
    Next i
    For Each IShape In ActiveSheet.Shapes
        If IShape.Type <> 8 Then IShape.Delete
    Next
    fldPath = ThisWorkbook.Path & "\images\"    'путь к папке с изображениями
    Application.ScreenUpdating = False
    fName = Dir(fldPath & "*.jpg")
    Do While fName <> ""
        art = Split(fName, ".")(0)
        If oDic.Exists(art) Then
            With Cells(oDic(art), 2)
                Set IShape = ActiveSheet.Shapes.AddPicture(fldPath & fName, False, True, .Left + 1, .Top + 1, -1, -1)
                Zm = WorksheetFunction.Min(.Width / IShape.Width, .Height / IShape.Height)
                IShape.Height = IShape.Height * Zm - 2
            End With
        End If
        fName = Dir
    Loop
    Application.ScreenUpdating = True
End Sub