Insertar y escalar una imagen con VBA

Tengo el siguiente código:

ActiveSheet.DrawingObjects.Delete
    ruta = ThisWorkbook.Path & "\Images\"
    For i = 2 To Range("e" & Rows.Count).End(xlUp).Row
        imagen = Cells(i, "e")
    If Cells(i, "e") = "" Then GoTo salidaa
    Range("b2").Select
    Dim SArchivo As String
    SArchivo = ruta & imagen & ".jpg"
    Set fso = CreateObject("Scripting.FileSystemObject")
    If fso.FileExists(SArchivo) Then
    Set img = Excel.ActiveSheet.Pictures.Insert(ruta & imagen & ".jpg")
    Else
    Set img = Excel.ActiveSheet.Pictures.Insert(ruta & "no image" & ".jpg")
    End If
        With Cells(i, "b")
            Arr = .Top
            Izq = .Left
            Anc = .Width
            Alt = .Height
        End With
        With img
            .ShapeRange.LockAspectRatio = msoFalse
            .Top = Arr
            .Left = Izq
            .Width = Anc
            .Height = Alt
        End With
        Set img = Nothing
salidaa:
    Next

Este código funciona perfecto, inserta las imágenes que tengo en la carpeta, según la variable de una celda y estira ocupando toda la celda. Esto estaba bien, pero hay imágenes que se me deforman mucho, necesitaría si son tan amables de poder corregirme el código para que la imagen se estire hasta tocar los margenes más próximos sin deformarse. Esto es ya que algunas fotos están en vertical y otras en horizontal y no quiero que queden tan deformadas.