How to insert pictures in Excel using Macro

Hi,

I'm facing 2 issues in using below code. 1st, suppose the image names are in column B from B2 to B11. Now, if the image against the image name in B7 is missing, then there only loop stops (it doesnt go till last row) and images of B8, B9 etc doesnt get pasted, even when they were there in the base image folder. So what i need is, i will keep a image with the name "NA" in my image folder, and i need if at any place image is not available, it will paste NA image against the same and move on to the last row.

2nd, after this working is done, how can i save my file or make changes in such a way that, even if i delete the base image folder or move the base image folder, images still reflect in excel. As of now, if i move the folder, images disappear.

Please help

Sub Picture()
Dim picname As String

Dim pasteAt As Integer
Dim lThisRow As Long

lThisRow = 2

Do While (Cells(lThisRow, 2) <> "")

'Range("A6").Select 'This is where picture will be inserted
pasteAt = Cells(lThisRow, 3)
Cells(pasteAt, 1).Select 'This is where picture will be inserted

'Dim picname As String
'picname = Range("B6") 'This is the picture name
picname = Cells(lThisRow, 2) 'This is the picture name

ActiveSheet.Pictures.Insert("C:\Users\vbayat\My Documents\vidabayat\re-market\" & picname & ".jpg").Select 'Path to where pictures are stored
'''''''''''''''''''''''''''''''''''''''''''''''''''''''
' This resizes the picture
'''''''''''''''''''''''''''''''''''''''''''''''''''''''
With Selection
'.Left = Range("A6").Left
'.Top = Range("A6").Top
.Left = Cells(pasteAt, 1).Left
.Top = Cells(pasteAt, 1).Top

.ShapeRange.LockAspectRatio = msoFalse
.ShapeRange.Height = 100#
.ShapeRange.Width = 80#
.ShapeRange.Rotation = 0#
End With

lThisRow = lThisRow + 1

Loop

Range("A10").Select
Application.ScreenUpdating = True

Exit Sub

ErrNoPhoto:
MsgBox "Unable to Find Photo" 'Shows message box if picture not found
Exit Sub
Range("B20").Select

End Sub