Public Sub InsPict()
    Dim arr, fldPath$, art$, fName$, i&, r0, lrow&, oDic As Object, IShape As Shape, Zm
    Dim v As Variant
    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)
        v = oDic(arr(i, 1))
        If IsEmpty(v) Then
            oDic(arr(i, 1)) = Array(i + r0 - 1)
        Else
            ReDim Preserve v(UBound(v) + 1)
            v(UBound(v)) = i + r0 - 1
            oDic(arr(i, 1)) = v
        End If
    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
            For Each v In oDic(art)
                With Cells(v, 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
            Next
        End If
        fName = Dir
    Loop
    Application.ScreenUpdating = True
End Sub