Macro for inserting pictures

[Reggie Jardin]

Hi,

I need a simple macro that will insert the pictures of Column A Name into Column B.
In column A2 cell the name is same as JPG Pic and it will should call that jpg pic according to its name and will adjust the cell size accrodingly to fit the pic.

The location of the pic is in one folder in D Drive.

Attached output excel fyr.

 

[Reggie Jardin]

Sub Picture1()
Dim lThisRow As Long, n As String, anyShape As Shape, l As Single, t As Single
Application.ScreenUpdating = False
lThisRow = 1
With ActiveSheet
Do While .Cells(lThisRow, 1).Value > ""
With .Cells(lThisRow, 1)
l = .Offset(, 2).Left
t = .Top
n = "D:\Macro-Pic\" & .Text
End With

If Dir(n) > "" Then
With .Pictures.Insert(n)
With .ShapeRange
.LockAspectRatio = msoFalse
.Height = 50
.Width = 50
.Rotation = 0
End With
.Top = t
.Left = l
.Placement = 1
End With
End If

lThisRow = lThisRow + 1
Loop

.Range("A11").Select
End With

Application.ScreenUpdating = True
MsgBox "Pic Inserted!"
End Sub

I got this Macro from previous thread but the problem is when i add another filename with.jpg extension in column A3 downwards its not calling my pictures but in cell A1 and A2 its working fine, and can someone modified this macro that the inserted pictures should adjust also the size of the cell according to its picture size. Thank You so much guys.

 

[Reggie Jardin]

Sub Picture1()
Dim lThisRow As Long, n As String, anyShape As Shape, l As Single, t As Single
Application.ScreenUpdating = False
                  lThisRow = 1
With ActiveSheet
    Do While .Cells(lThisRow, 1).Value > ""
        With .Cells(lThisRow, 1)
            l = .Offset(, 2).Left
            t = .Top
            n = "D:\Macro-Pic\" & .Text
        End With
        If Dir(n) > "" Then
            With .Pictures.Insert(n)
                With .ShapeRange
                    .LockAspectRatio = msoFalse
                              .Height = 50
                              .Width = 50
                            .Rotation = 0
                End With
                      .Top = t
                    .Left = l
                .Placement = 1
            End With
        End If
        lThisRow = lThisRow + 1
    Loop

    .Range("A11").Select
End With

Application.ScreenUpdating = True
MsgBox "Pic Inserted!"
End Sub

HI Guys this is the macro code but issue is

1.) It's not adjusting the cell according to picture size.
2.) If The A column where i need to call the pictures accroding to its file name is blank (null) its not calling the other pictures next to its row..

Pls check attached output fyr.