Private Sub кнопка_Click()
Dim IFile As String 'Имя файла
Dim Kartinka As Object
Dim TempSheet As Worksheet
Dim a As String
Dim k As Integer
Dim i As Long
Dim Teg As Boolean

Teg = False
If Список.Text = "" Then Exit Sub
Application.ScreenUpdating = False
Application.DisplayAlerts = False
With ActiveSheet
    For i = 1 To .Cells(.Rows.Count, 2).End(xlUp).Row
        If .Cells(i, 2).Text = Список.Text Then Exit For
    Next
    For k = 1 To .Shapes.Count
        If Not Intersect(.Range(.Cells(i, 3).Address(0, 0)), Range(.Shapes(k).TopLeftCell.Address(0, 0))) Is Nothing Then
            Teg = True
            Exit For
        End If
    Next k
    If Teg = False Then MsgBox "Картинка отсутствует", vbExclamation: Exit Sub
    .Shapes(k).Select
End With
Set Kartinka = Selection: Kartinka.Copy
Set TempSheet = ThisWorkbook.Sheets.Add
IFile = ActiveWorkbook.Name & ActiveSheet.Name & Kartinka.Name
a = Environ$("temp") & "\" & IFile & ".GIF"
With TempSheet.ChartObjects.Add(0, 0, Kartinka.Width, Kartinka.Height).Chart
    .ChartArea.Border.LineStyle = 0
    .Paste
    .Export Filename:=a, FilterName:="GIF"
End With
TempSheet.Delete
Картинка.Picture = LoadPicture(a)
Kill a
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub