Macro that will insert and resize picture in selected cell range

Hi,

I am looking for a macro that will insert and automatically resize the image into the cell range I select. I have been using the below code which works great but it is specific to the range I input into the macro. Is there any way the macro can realize the cells I have selected to paste the photo in and adjust the range on its own.


Sub TestInsertPictureInRange()
Dim picToOpen As String
picToOpen = Application _
.GetOpenFilename("Pics (*.jpg), *.jpg")
If picToOpen <> "" Then InsertPictureInRange picToOpen, _
Range("B5:D10")
End Sub

Sub InsertPictureInRange(PictureFileName As String, TargetCells As Range)
' inserts a picture and resizes it to fit the TargetCells range
Dim p As Object, t As Double, l As Double, w As Double, h As Double
If TypeName(ActiveSheet) <> "Worksheet" Then Exit Sub
If Dir(PictureFileName) = "" Then Exit Sub
' import picture
Set p = ActiveSheet.Pictures.Insert(PictureFileName)
' determine positions
With TargetCells
t = .Top
l = .Left
w = .Offset(0, .Columns.Count).Left - .Left
h = .Offset(.Rows.Count, 0).Top - .Top
End With
' position picture
With p
.Top = t
.Left = l
.Width = w
.Height = h
End With
Set p = Nothing
End Sub



Thanks for any help

Thank you for replying, can you repost the code with the correction, I am not sure I am debugging as you suggested... thank you.

Thank you Very much. I found the problem along with your solution xladept. I will post the complete code for anyone who may need it. Thanks.

Sub TestInsertPictureInRange()
Dim picToOpen As String
picToOpen = Application _
.GetOpenFilename("Pics (*.jpg), *.jpg")
If picToOpen <> "" Then _
InsertPictureInRange picToOpen, Selection
End Sub

Sub InsertPictureInRange(PictureFileName As String, TargetCells As range)
' inserts a picture and resizes it to fit the TargetCells range
Dim p As Object, t As Double, l As Double, w As Double, h As Double, r As Integer
If TypeName(ActiveSheet) <> "Worksheet" Then Exit Sub
If Dir(PictureFileName) = "" Then Exit Sub
' import picture
Set p = ActiveSheet.Pictures.Insert(PictureFileName)
' determine positions
With TargetCells
t = .Top
l = .Left
w = .Width
h = .Height
End With
' position picture
With p
.Top = t
.Left = l
.Width = w
.Height = h
End With
Set p = Nothing
End Sub