Sub GetImage1()
  Dim img, img1 As Picture, T, L, W, h As Single
  Dim CellX As Single
  Dim GetOne As String
    'p = ActiveWorkbook.Path
    ' ChDir p
    GetOne = Application.GetOpenFilename("Image Files (*.jpg;*.bmp;*.gif;*.ico), *.jpg;*.bmp;*.gif;*.ico")
   Application.ScreenUpdating = False

 
  With ActiveCell
           L = .MergeArea.Left
           T = .MergeArea.Top
           W = .MergeArea.Width
           h = .MergeArea.Height
           CellX = h / W
 On Error Resume Next
  ActiveWorkbook.ActiveSheet.Shapes.AddPicture GetOne, False, True, L, T, W, H - картинка в границы ячейки и остается в файле 
  'ActiveSheet.Pictures.Insert(GetOne).Select - картинка пропорционально подгоняется под границы ячейи, но не остается в файле при переносе на другой комп.
  With Selection.ShapeRange
        .LockAspectRatio = True
        .Placement = xlMove
     If .Height / .Width > CellX Then
         .Height = h - 4
         .Left = L + (W - .Width) / 2
         .Top = T + 2
     Else
         .Width = W - 4
         .Top = T + (h - .Height) / 2
         .Left = L + 2
     End If
         L = .Left
         T = .Top
         h = .Height
         W = .Width
       .Width = .Width
     End With
 End With
 Application.ScreenUpdating = True
 
End Sub