Vba Fit All Picture With Simultaneously

muhammad susanto

Well-known Member
Joined
Jan 8, 2013
Messages
2,089
Office Version
  1. 365
  2. 2021
Platform
  1. Windows
hi all...
this following code work properly only for single picture.
i want someone would help me to modify that code so that work in multiple picture, with logic "select your all pictures before running this macro" the run ok.
my all picture in cell N36:O36 down
here is this code :
VBA Code:
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

any help, greatly appreciated..

.sst
 
Last edited:

Excel Facts

Best way to learn Power Query?
Read M is for (Data) Monkey book by Ken Puls and Miguel Escobar. It is the complete guide to Power Query.
One way ..

VBA identifies shapes automatically (user not required to select)
Call your sub like this

VBA Code:
Sub CallFitPic()
    Dim rng As Range, cel As Range, shp As Shape
    Set rng = Range("N36:O" & Rows.Count)
    For Each shp In ActiveSheet.Shapes
        Set cel = shp.TopLeftCell
        If Not Intersect(cel, rng) Is Nothing Then
            shp.Select
            Call FitPic
        End If
    Next shp
End Sub
 
Upvote 0
One way ..

VBA identifies shapes automatically (user not required to select)
Call your sub like this

VBA Code:
Sub CallFitPic()
    Dim rng As Range, cel As Range, shp As Shape
    Set rng = Range("N36:O" & Rows.Count)
    For Each shp In ActiveSheet.Shapes
        Set cel = shp.TopLeftCell
        If Not Intersect(cel, rng) Is Nothing Then
            shp.Select
            Call FitPic
        End If
    Next shp
End Sub
hi yongle...

your code not work..show like this
 

Attachments

  • callfit.png
    callfit.png
    4.3 KB · Views: 24
Upvote 0
It is calling the sub you posted and works for me
Where did you put FitPic ?
 
Upvote 0
i just only run your code..
or it's combine with my code before?
VBA Code:
Sub CallFitPic()
    Dim rng As Range, cel As Range, shp As Shape
    Set rng = Range("N36:O" & Rows.Count)
    For Each shp In ActiveSheet.Shapes
        Set cel = shp.TopLeftCell
        If Not Intersect(cel, rng) Is Nothing Then
            shp.Select
            Call FitPic
        End If
    Next shp
End Sub
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
 
Upvote 0
The macros do not require combining
Place both macros in the same module and then run my macro
 
Upvote 0

Forum statistics

Threads
1,223,911
Messages
6,175,331
Members
452,636
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