Application.ScreenUpdating = False
Sheets("ÊÏ").Activate -'Открытие листа с ссылками'
Dim theShape As Shape
Dim xRg As Range
Dim xCol As Long
On Error Resume Next
Application.ScreenUpdating = False
Set Rng = ActiveSheet.Range("A1:A10") ' <---- Диапазон ссылок'
For Each cell In Rng
Filename = cell

ActiveSheet.Pictures.Insert(Filename).Select
Set theShape = Selection.ShapeRange.Item(1)
If theShape Is Nothing Then GoTo isnill
xCol = cell.Column + 1
Set xRg = Cells(cell.Row, xCol)
With theShape
.LockAspectRatio = msoFalse
.Width = 350
.Height = 300
.Top = xRg.Top + (xRg.Height - .Height) / 2
.Left = xRg.Left + (xRg.Width - .Width) / 2
End With
isnill:
Set theShape = Nothing
Range("A2").Select

Next

Debug.Print "Done " & Now