Picture resizing to a range of cells

[Geo000]

Sub Show_DogPic()
Dim PicPath As String
With Sheet2
On Error Resume Next
.Shapes("DogPic").Delete 'Delete Picture if it exists
On Error GoTo 0
PicPath = .Range("BI1").Value 'Path of the picture
If PicPath = "0" Then
.Shapes("DefaultPicture").Visible = msoCTrue
Exit Sub
End If
.Shapes("DefaultPicture").Visible = msoFalse
With .Pictures.Insert(PicPath)
With .ShapeRange
.LockAspectRatio = msoTrue
.Height = 72
.Name = "DogPic"
End With 'Shape Range
End With 'Pictures

With .Shapes("Dogpic")
.Left = Sheet2.Range("BA3").Left
.Top = Sheet2.Range("BA3").Top
.IncrementLeft 3
.IncrementTop 4



End With 'Sheet2
End With
End Sub

Hi All
could anyone tell me how i can resize the pictures to a specific range of cells as some are larger in height and some just aint got the width
im starting to pull my hair out now with this any help greatly appreciated. ??

 

[Geo000]

Hi
sorry forgot to say i need the pic to fill cells BA3:BE7 so i would need to Auto resize some how ????