Sub InsertCapt()
    Dim i&
    Dim o, key$
    Dim w As Single, h As Single, px As Single, py As Single
    Dim kst As Single, sc As Single
    Dim shp, pcentW As Single
    Set o = CreateObject("Scripting.Dictionary")
    'удаляем все картинки, середина (по ширине) которых не вылезает за границы столбца "J"
    For Each shp In ActiveSheet.Shapes
        pcentW = shp.Left + shp.Width / 2
        With Cells(1, 10)
            If pcentW > .Left And pcentW < .Left + .Width Then
                shp.Delete
            End If
        End With
    Next shp
    'создаём словарик с соответствием цифры (из столбца I) - ссылке на рисунок
    For i = 7 To Cells(Rows.Count, 22).End(xlUp).Row
        key = Cells(i, 21)
        If Not o.exists(key) Then
            o.Add key, CStr(Cells(i, 22))
        End If
    Next i
    'Вставляем картинку и подгоняем по размеру
    For i = 7 To Cells(Rows.Count, 9).End(xlUp).Row
        If Cells(i, 9) <> "" Then
            With Cells(i, 10)
                w = .Width
                h = .Height
                px = .Left
                py = .Top
            End With
            kst = w / h
            On Error GoTo A
            With ActiveSheet.Pictures.Insert(o(CStr(Cells(i, 9))))
                If (.Width / .Height) < kst Then
                    sc = h / .Height
                Else
                    sc = w / .Width
                End If
                .ShapeRange.ScaleWidth sc, msoFalse, msoScaleFromTopLeft '
                .Left = px + (w - .Width) / 2
                .Top = py + (h - .Height) / 2
'                .ShapeRange.ScaleHeight sc, msoFalse, msoScaleFromTopLeft
            End With
        End If
    Next i
A:     MsgBox "Вероятно, ссылка на картинку(ки) не действительна." & Chr(13) _
                & "Работа макроса будет прекращена!"

End Sub