Resize picture macro Excel 2007

[hank153]

I came across the following macro to resize a picture to fit any cell in Excel. It works great as long as it is not a MERGED cell.
Can anyone tell he how to change it to make it work in merged cells or is that possible???

I don't know who wrote the code, but they did a great job.

Public Sub FitPic()
On Error GoTo NOT_SHAPE
Dim PicWtoHRatio As Single
Dim CellWtoHRatio As Single
With Selection
PicWtoHRatio = .Width / .Height
End With
With Selection.TopLeftCell
CellWtoHRatio = .Width / .RowHeight
End With
Select Case PicWtoHRatio / CellWtoHRatio
Case Is > 1
With Selection
.Width = .TopLeftCell.Width
.Height = .Width / PicWtoHRatio
End With
Case Else
With Selection
.Height = .TopLeftCell.RowHeight
.Width = .Height * PicWtoHRatio
End With
End Select
With Selection
.Top = .TopLeftCell.Top
.Left = .TopLeftCell.Left
End With
Exit Sub
NOT_SHAPE:
MsgBox "Select a picture before running this macro."
End Sub

 

[JoeMo]

Welcome to the board.

See if this does what you want:

Public Sub FitPic()
If TypeName(Selection) <> "Picture" Then GoTo NOT_SHAPE
Dim PicWtoHRatio As Single
Dim CellWtoHRatio As Single
With Selection
    PicWtoHRatio = .Width / .Height
End With
With Selection.TopLeftCell
    If .MergeCells Then
        CellWtoHRatio = .MergeArea.Width / .MergeArea.Height
    Else
        CellWtoHRatio = .Width / .RowHeight
    End If
End With
Select Case PicWtoHRatio / CellWtoHRatio
    Case Is > 1
        With Selection
            If .TopLeftCell.MergeCells Then
                .Width = .TopLeftCell.MergeArea.Width
            Else
                .Width = .TopLeftCell.Width
            End If
            .Height = .Width / PicWtoHRatio
        End With
    Case Else
        With Selection
            If .TopLeftCell.MergeCells Then
                .Height = .TopLeftCell.MergeArea.Height
            Else
                .Height = .TopLeftCell.RowHeight
            End If
            .Width = .Height * PicWtoHRatio
        End With
End Select
With Selection
    .Top = .TopLeftCell.Top
    .Left = .TopLeftCell.Left
End With
Exit Sub
NOT_SHAPE:
MsgBox "Select a picture before running this macro."
End Sub

 

[hank153]

Joe,
Just what I needed. Thanks for your help.
Hank

 

[JoeMo]

Joe,
Just what I needed. Thanks for your help.
Hank

You are welcome - thanks for the reply.