Sub Макрос_перенос_картинок()
     Dim A(3) As Integer
     Dim Shape1 As Shape
     Dim B(3)
     Dim Mashtab
     A(1) = Cells(7, 1)
     A(2) = Cells(7, 2)
     A(3) = Cells(7, 3)
     Set B(1) = Range(Cells(7, 7), Cells(10, 7))
     Set B(2) = Range(Cells(7, 9), Cells(10, 9))
     Set B(3) = Range(Cells(7, 12), Cells(10, 10))
     For i = 1 To 3
       For Each Shape1 In ActiveSheet.DrawingObjects.ShapeRange
         If Not Intersect(Range(Shape1.TopLeftCell, Shape1.BottomRightCell), B(A(i))) Is Nothing Then
           Shape1.Select
         End If
       Next Shape1
       Selection.Copy
       Mashtab = Cells(8, i)
          With Selection.Copy
           Selection.ShapeRange.ScaleHeight 1.25, msoFalse, msoScaleFromTopLeft
          End With
       Cells(9, i).Select
       ActiveSheet.Paste
     Next i
End Sub

Selection.ShapeRange.ScaleHeight 1.25, msoFalse, msoScaleFromTopLeft

Selection.ShapeRange.ScaleHeight cells(8,i), msoFalse, msoScaleFromTopLeft

Public Sub StoreFile(ByVal FileName As String)
     Dim pSheet As Worksheet, fSize As Long
     Dim vData() As Byte, fNum As Integer
     Dim fso As New Scripting.FileSystemObject
      
     Set pSheet = ThisWorkbook.Worksheets(1)
     fSize = fso.GetFile(FileName).Size
     ReDim vData(1 To fSize)
     fNum = FreeFile
     Open FileName For Binary As #fNum
     Get #fNum, , vData
     Close #fNum
     pSheet.CustomProperties.Add FileName, vData
End Sub

Public Function GetResourceName(ByVal ResourceName As String) As String
     Dim i As Long, sName As String, fso As New Scripting.FileSystemObject
     Dim pCProp As CustomProperty, pSheet As Worksheet
     Dim vData() As Byte, fNum As Integer
     Set pSheet = ThisWorkbook.Worksheets(1)
     sName = ""
     For i = 1 To pSheet.CustomProperties.Count
         Set pCProp = pSheet.CustomProperties(i)
         If StrComp(pCProp.Name, ResourceName, vbTextCompare) = 0 Then
             sName = pCProp.Name
             Exit For
         End If
     Next
     If sName <> "" Then
         i = InStrRev(sName, "\")
         sName = fso.GetSpecialFolder(2) & Mid$(sName, i)
         If Not fso.FileExists(sName) Then
             vData = pCProp.Value
             fNum = FreeFile
             Open sName For Binary As #fNum
             Put #fNum, , vData
             Close #fNum
         End If
     End If
     GetResourceName = sName
End Function

Comment.Shape.Fill.UserPicture "d:\path\name.jpg"

.Cells(A.Row, A.Columns(i).Column).AddComment.Shape.Fill.UserPicture "Полный адрес картинки"