Sub kartinki_von()
Dim i As Long, i_n As Long
Dim obj As Shape
Dim NWS As Worksheet, AWS As Worksheet
Set AWS = ActiveSheet
Set NWS = ActiveWorkbook.Sheets.Add
i_n = AWS.Cells(Rows.Count, 2).End(xlUp).Row
For i = 2 To i_n
For Each obj In AWS.Shapes
If obj.Type = 13 Then
    If RoundPlace(AWS.Cells(i, 2), obj) Then
    obj.Copy
    With NWS.ChartObjects.Add(0, 0, obj.Width, obj.Height).Chart
        .ChartArea.Border.LineStyle = 0
        .Paste
        .Export Filename:=ActiveWorkbook.Path & "\" & AWS.Cells(i, 2) & ".jpg", FilterName:="JPG"
        .Parent.Delete
    End With
    End If
End If
Next obj
Next i
Application.DisplayAlerts = False
NWS.Delete
Application.DisplayAlerts = True
End Sub
Function RoundPlace(r As Range, shp As Shape) As Boolean
    Dim Middle As Single
    Middle = shp.Top + shp.Height / 2
    RoundPlace = (r.Top <= Middle And Middle < r.Top + r.Height)
End Function

Sub kartinki_von()
Dim i As Long, i_n As Long
Dim obj As Shape
Dim NWS As Worksheet, AWS As Worksheet
Set AWS = ActiveSheet
Set NWS = ActiveWorkbook.Sheets.Add
i_n = AWS.Cells(Rows.Count, 2).End(xlUp).Row
Application.ScreenUpdating = False
For i = 2 To i_n
For Each obj In AWS.Shapes
  If obj.Type = 13 Then
    If AWS.Cells(i, 2).Top = obj.BottomRightCell.Top Then
       obj.Copy
       With NWS.ChartObjects.Add(0, 0, obj.Width, obj.Height).Chart
           .ChartArea.Select
           .ChartArea.Border.LineStyle = 0
           .Paste
           .Export Filename:=ActiveWorkbook.Path & "\" & AWS.Cells(i, 2) & ".jpg", FilterName:="JPG"
           .Parent.Delete
       End With
    End If
  End If
Next obj
Next i
Application.DisplayAlerts = False
NWS.Delete
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub