Excel Forum

Code: Select all

Sub FitPicture()
On Error GoTo NOT_SHAPE
Dim r As Range, sel As Shape
Set sel = ActiveSheet.Shapes(Selection.Name)

sel.LockAspectRatio = msoTrue
Set r = Range(sel.TopLeftCell.MergeArea.Address)
    ActiveSheet.Shapes.Range(Array("Picture 1")).Select
    Selection.ShapeRange.Left = [A11].Left
Selection.ShapeRange.Top = [A11].Top
Select Case (r.Width / r.Height) / (sel.Width / sel.Height)
    Case Is > 1
        sel.Height = r.Height * 0.9
    Case Else
        sel.Width = r.Width * 0.9
End Select
sel.Top = r.Top + (r.Height - sel.Height) / 2
sel.Left = r.Left + (r.Width - sel.Width) / 2
Exit Sub
NOT_SHAPE:
MsgBox "Please select a picture first."
End Sub