Auto resize image in Excel merged cell

[TPortsmouth]

I've tried the below VBA code to auto resize image in Excel workbook. It fits with the cell.

<code>Public Sub FitPicture()
    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 "Please select a picture first."
End Sub</code>

However, can anyone help me how to make it valid on merged cell?

Thanks.

 

[Worf]

Welcome to the Board

This will work with merged or unmerged cells:

Public Sub FitPicture()
On Error GoTo NOT_SHAPE
Dim r As Range
Set r = Range(Selection.TopLeftCell.MergeArea.Address)
With Selection
    .Width = r.Width
    .Height = r.Height
    .Top = r.Top
    .Left = r.Left
End With
Exit Sub
NOT_SHAPE:
MsgBox "Please select a picture first."
End Sub

 

[TPortsmouth]

Hi Worf,

Thanks so much for you help.

However, if the column width is larger than the row height, the image will become larger then the merged, can the Macro be further modify to keep the ratio and not larger than the merged cell?

 

[Worf]

Here is what I understand from your request:

• Always keep the image aspect ratio.
• Align the image top left position with the merge area top left position.
• Unless the aspect ratios are the same, the merge area will have an uncovered part, either to the right or at the bottom.
• The whole merge area can be used, not just the upper left cell of it.

Is all of the above correct?

 

[TPortsmouth]

Here is what I understand from your request:

• Always keep the image aspect ratio.
• Align the image top left position with the merge area top left position.
• Unless the aspect ratios are the same, the merge area will have an uncovered part, either to the right or at the bottom.
• The whole merge area can be used, not just the upper left cell of it.

Is all of the above correct?

Yes for point #1, 2 & 4, but as for #3, the image should not exceed the merged cell, should keep either the longest column width or row height.

 

[Worf]

New version:

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)

Select Case (r.Width / r.Height) / (sel.Width / sel.Height)
    Case Is > 1
        sel.Height = r.Height
    Case Else
        sel.Width = r.Width
End Select

sel.Top = r.Top: sel.Left = r.Left
Exit Sub
NOT_SHAPE:
MsgBox "Please select a picture first."
End Sub

 

[TPortsmouth]

Hi Worf,

This is perfect, thank you so much for your help.

Cheers.

 

[nguyenphanduong]

New version:

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)

Select Case (r.Width / r.Height) / (sel.Width / sel.Height)
    Case Is > 1
        sel.Height = r.Height
    Case Else
        sel.Width = r.Width
End Select

sel.Top = r.Top: sel.Left = r.Left
Exit Sub
NOT_SHAPE:
MsgBox "Please select a picture first."
End Sub

Hi Worf,
Your code is so great but in my case, I want the dimension scale between picture and cell is 9/10 and the picture is in middle and center of the cell. Please help me.
Thank you so much!

 

[Worf]

Welcome to the Board

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)
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