Hi Guys,



This VBA import the picture in the original size into the sheet when selecting the picture and run the vba it is pasting cell size picture in the first A column but not in the active cell where i keep my cursor.. I want the picture to be resized into the desired cell.

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
'Step 4: Press the F5 key to run this macro.
'Step 5: Repeat the steps above to resize other pictures to fit single cell.