Insert picture corresponding to cell value using excel macro - vba

Question

I'm using the macro below to insert the picture corresponding to the value in Cell P2 into cell Q2.
This works for the one cell selected (P2 in this case).
I want to create a loop to do the same action for the rows in Column P range (P2:P500) that are not blank.
Sub Picture()
Range("Q2").Select
Dim picname As String
picname = "C:\Users\kisnahr\Pictures\Test\" & Range("P2") & ".bmp" 'Link to the picture
ActiveSheet.Pictures.Insert(picname).Select
With Selection
.Left = Range("Q2").Left
.Top = Range("Q2").Top
.ShapeRange.LockAspectRatio = msoFalse
.ShapeRange.Height = 80#
.ShapeRange.Width = 80#
.ShapeRange.Rotation = 0#
End With
Range("Q10").Select
Application.ScreenUpdating = True
Exit Sub
ErrNoPhoto:
MsgBox "Unable to Find Photo" 'Shows message box if picture not found
Exit Sub
Range("P20").Select
End Sub

Answer 1

Try something along these lines. This is a very rough and ready solution, so you'll need to adapt it to your own requirements. Here I've put the image path in column B and is fired off from a CommandButton4 click. Not sure how you define your cell Left and Cell Top though?
Private Sub CommandButton4_Click()
Dim MyRange As String
Dim picname As String
Dim mySelectRange As String
Dim rcell As Range
Dim IntInstr As Integer
Dim Mypath As String
Mypath = "z:\My Pictures"
MyRange = "B2:B500"
Range(MyRange).Select
For Each rcell In Selection.Cells
If Len(rcell.value) > 0 Then
picname = Mypath & rcell.value
mySelectRange = Replace(MyRange, "B", "A")
IntInstr = InStr(mySelectRange, ":")
mySelectRange = Left(mySelectRange, IntInstr - 1)
do_insertPic picname, mySelectRange, rcell.Left, rcell.Top
End If
Next
Application.ScreenUpdating = True
End Sub
Private Sub do_insertPic(ByRef picname As String, ByRef MyRange As String, myleft As Integer, mytop As Integer)
Dim rcell As Range
Range(MyRange).Select
On Error GoTo ErrNoPhoto
ActiveSheet.Pictures.Insert(picname).Select
On Error GoTo 0
With Selection
.Left = myleft
.Top = mytop
.ShapeRange.LockAspectRatio = msoFalse
.ShapeRange.Height = 80#
.ShapeRange.Width = 80#
.ShapeRange.Rotation = 0#
End With
Exit Sub
ErrNoPhoto:
MsgBox "Unable to Find Photo" 'Shows message box if picture not found
End Sub

Answer 2

I use following, so the sheet can be mailed etc. :
'Picname in Column B7 and corresponding picture in Column M7
Sub Picture()
Dim picname As String
Dim shp As Shape
Dim pasteAt As Integer
Dim lThisRow As Long
lThisRow = 7 'This is the start row
Do While (Cells(lThisRow, 2) <> "")
pasteAt = lThisRow
Cells(pasteAt, 13).Select 'This is where picture will be inserted (column)
picname = Cells(lThisRow, 2) 'This is the picture name
present = Dir("C:\foto\" & picname & ".jpg")
If present <> "" Then
Cells(pasteAt, 13).Select
Call ActiveSheet.Shapes.AddPicture("C:\foto\" & picname & ".jpg", _
msoCTrue, msoCTrue, Left:=Cells(pasteAt, 13).Left, Top:=Cells(pasteAt, 13).Top, Width:=100, Height:=100).Select
Else
Cells(pasteAt, 14) = "No Picture Found"
End If
lThisRow = lThisRow + 1
Loop
Range("A1").Select
Application.ScreenUpdating = True
Exit Sub
ErrNoPhoto:
MsgBox "Unable to Find Photo" 'Shows message box if picture not found
Exit Sub
Range("O7").Select
End Sub