Inserting multiple images based on cell value

Closed
Report
-
Hello,

I hope to find some help here as I would really like to find an easier way than just insert each picture manually. I have range of cells value which I need to add pictures for (hundred of cells values). For this example cell values:
B1: Title
B2: Desert
B2: Jellyfish
B3: Koala
I would like to add picture in Column A based on value in Column B. I found a VBA online and modified it slight however it producing "No picture Found" message even though picture is in the directory file. Please help.
The step I took are:
1. Open Excel 2010
2. Enter the reference value in Column B
3. Open VBA in Excel
4. Insert a module
5. Copy and past the formula below and click the play button
__________________________

Sub Picture()
Dim pictureNameColumn As String 'column where picture name is found
Dim picturePasteColumn As String 'column where picture is to be pasted

Dim pictureName As String 'picture name
Dim lastPictureRow As Long 'last row in use where picture names are
Dim pictureRow As Long 'current picture row to be processed
Dim pathForPicture As String 'path of pictures

pictureNameColumn = "B"
picturePasteColumn = "A"

pictureRow = 2 'starts from this row

'error handler
On Error GoTo Err_Handler

'find row of the last cell in use in the column where picture names are
lastPictureRow = Cells(Rows.Count, pictureNameColumn).End(xlUp).Row

'stop screen updates while macro is running
Application.ScreenUpdating = False

pathForPicture = "C:\Users\Public\Pictures\Sample Pictures"
'loop till last row
Do While (pictureRow <= lastPictureRow)

pictureName = Cells(pictureRow, "B") 'This is the picture name

'if picture name is not blank then
If (pictureName <> vbNullString) Then
'check if pic is present
If (Dir(pathForPicture & pictureName & ".jpeg") <> vbNullString) Then

Cells(pictureRow, picturePasteColumn).Select 'This is where picture will be inserted
ActiveSheet.Pictures.Insert(pathForPicture & pictureName & ".jpeg").Select 'Path to where pictures are stored

With Selection
.Left = Cells(pictureRow, picturePasteColumn).Left
.Top = Cells(pictureRow, picturePasteColumn).Top
.ShapeRange.LockAspectRatio = msoFalse
.ShapeRange.Height = 100#
.ShapeRange.Width = 130#
.ShapeRange.Rotation = 0#
End With
Else
'picture name was there, but no such picture
Cells(pictureRow, picturePasteColumn) = "No Picture Found"
End If
Else
'picture name cell was blank
End If
'increment row count
pictureRow = pictureRow + 1
Loop

Exit_Sub:
Range("A10").Select
Application.ScreenUpdating = True
Exit Sub

Err_Handler:
MsgBox "Error encountered. " & Err.Description, vbCritical, "Error"
GoTo Exit_Sub

End Sub
____________________________

I checked to make sure the file extension (jpeg) are correct. How can I repair this? Help.