Thread: Vba to insert picture into desired cell with cell size
View Single Post
 
Old 10-20-2018, 02:06 PM
p45cal's Avatar
p45cal p45cal is offline Windows 10 Office 2016
Expert
  
Join Date: Apr 2014
Posts: 947
p45cal has a reputation beyond reputep45cal has a reputation beyond reputep45cal has a reputation beyond reputep45cal has a reputation beyond reputep45cal has a reputation beyond reputep45cal has a reputation beyond reputep45cal has a reputation beyond reputep45cal has a reputation beyond reputep45cal has a reputation beyond reputep45cal has a reputation beyond reputep45cal has a reputation beyond repute
Default
The macro you've provided requires the active selection to be a picture. No problem. Just make sure that the active cell before you select the picture and run this tweaked macro is the cell you want the picture to be in.
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 ActiveCell
  CellWtoHRatio = .Width / .RowHeight
End With
Select Case PicWtoHRatio / CellWtoHRatio
  Case Is > 1
    With Selection
      .Width = ActiveCell.Width
      .Height = .Width / PicWtoHRatio
    End With
  Case Else
    With Selection
      .Height = ActiveCell.RowHeight
      .Width = .Height * PicWtoHRatio
    End With
End Select
With Selection
  .Top = ActiveCell.Top
  .Left = ActiveCell.Left
End With
Exit Sub
NOT_SHAPE:
MsgBox "Select a picture before running this macro."
End Sub