Fit all selected pictures to cell size - vba macro

Exhale2020

New Member
Joined
Sep 30, 2018
Messages
13
Hi all,

I've been using the below macro to fit pics into the cell which they reside in.

It's working fine if I select one pic at a time but fails for more than one. I would like to save more time by making it applicable to all selected pictures to fit (and aligned) in the cell which they reside in. All of the cells could be equally sized if that helps.

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

Thanks!
 

Excel Facts

Easy bullets in Excel
If you have a numeric keypad, press Alt+7 on numeric keypad to type a bullet in Excel.
Try this:
Code:
Public Sub Fit_All_Selected_Pictures()

    Dim pic As Picture
    Dim PicWtoHRatio As Single
    Dim CellWtoHRatio As Single
    
    Select Case TypeName(Selection)
    
        Case "DrawingObjects"
        
            For Each pic In Selection
                PicWtoHRatio = pic.Width / pic.Height
                CellWtoHRatio = pic.TopLeftCell.Width / pic.TopLeftCell.RowHeight
                Select Case PicWtoHRatio / CellWtoHRatio
                    Case Is > 1
                        With pic
                            .Width = .TopLeftCell.Width
                            .Height = .Width / PicWtoHRatio
                        End With
                    Case Else
                        With pic
                            .Height = .TopLeftCell.RowHeight
                            .Width = .Height * PicWtoHRatio
                        End With
                End Select
                With pic
                    .Top = .TopLeftCell.Top
                    .Left = .TopLeftCell.Left
                End With
            Next
            
        Case "Picture"
    
            Set pic = Selection
            PicWtoHRatio = pic.Width / pic.Height
            CellWtoHRatio = pic.TopLeftCell.Width / pic.TopLeftCell.RowHeight
            Select Case PicWtoHRatio / CellWtoHRatio
                Case Is > 1
                    With pic
                        .Width = .TopLeftCell.Width
                        .Height = .Width / PicWtoHRatio
                    End With
                Case Else
                    With pic
                        .Height = .TopLeftCell.RowHeight
                        .Width = .Height * PicWtoHRatio
                    End With
            End Select
            With pic
                .Top = .TopLeftCell.Top
                .Left = .TopLeftCell.Left
            End With
   
        Case Else
        
            MsgBox "Select 1 or multiple pictures before running this macro."
            
    End Select
    
End Sub
 
Upvote 0
Try this:
Code:
Public Sub Fit_All_Selected_Pictures()

    Dim pic As Picture
    Dim PicWtoHRatio As Single
    Dim CellWtoHRatio As Single
    
    Select Case TypeName(Selection)
    
        Case "DrawingObjects"
        
            For Each pic In Selection
                PicWtoHRatio = pic.Width / pic.Height
                CellWtoHRatio = pic.TopLeftCell.Width / pic.TopLeftCell.RowHeight
                Select Case PicWtoHRatio / CellWtoHRatio
                    Case Is > 1
                        With pic
                            .Width = .TopLeftCell.Width
                            .Height = .Width / PicWtoHRatio
                        End With
                    Case Else
                        With pic
                            .Height = .TopLeftCell.RowHeight
                            .Width = .Height * PicWtoHRatio
                        End With
                End Select
                With pic
                    .Top = .TopLeftCell.Top
                    .Left = .TopLeftCell.Left
                End With
            Next
            
        Case "Picture"
    
            Set pic = Selection
            PicWtoHRatio = pic.Width / pic.Height
            CellWtoHRatio = pic.TopLeftCell.Width / pic.TopLeftCell.RowHeight
            Select Case PicWtoHRatio / CellWtoHRatio
                Case Is > 1
                    With pic
                        .Width = .TopLeftCell.Width
                        .Height = .Width / PicWtoHRatio
                    End With
                Case Else
                    With pic
                        .Height = .TopLeftCell.RowHeight
                        .Width = .Height * PicWtoHRatio
                    End With
            End Select
            With pic
                .Top = .TopLeftCell.Top
                .Left = .TopLeftCell.Left
            End With
   
        Case Else
        
            MsgBox "Select 1 or multiple pictures before running this macro."
            
    End Select
    
End Sub

Works perfectly thanks John
 
Upvote 0

Forum statistics

Threads
1,223,911
Messages
6,175,324
Members
452,635
Latest member
laura12345

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top