вытащить картинки из экселя и проставить имена картинок в ячейки

Sub Save_Object_As_Picture()
Dim li As Long, oObj As Shape, wsSh As Worksheet, wsTmpSh As Worksheet
Dim sImagesPath As String, sName As String

sImagesPath = ActiveWorkbook.Path & "\images\" '"
If Dir(sImagesPath, 16) = "" Then
MkDir sImagesPath
End If
On Error Resume Next
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Set wsSh = ActiveSheet
Set wsTmpSh = ActiveWorkbook.Sheets.Add
For Each oObj In wsSh.Shapes
If oObj.Type = 13 Then
li = li + 1
oObj.Copy
sName = "img" & li
With wsTmpSh.ChartObjects.Add(0, 0, oObj.Width, oObj.Height).Chart
.ChartArea.Border.LineStyle = 0
.Parent.Select
.Paste
.Export Filename:=sImagesPath & sName & ".jpg", FilterName:="JPG"
.Parent.Delete
End With
oObj.TopLeftCell.Value = sName
oObj.Delete 'удаляем картинку с листа
End If
Next oObj
Set oObj = Nothing: Set wsSh = Nothing
wsTmpSh.Delete
Application.DisplayAlerts = True
Application.ScreenUpdating = True
MsgBox "Объекты сохранены в папке: " & sImagesPath, vbInformation, "www.excel-vba.ru"
End Sub

Подробнее здесь — https://www.excel-vba.ru/chto-umeet-excel/kak-soxranit-kartinki-iz-lista-excel-v-kartinki-jpg/