Insert picture based on cell value

[NIHSCTEST]

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: Desert
B2: Jellyfish
B3: Koala

I'm looking to insert image so these values into column A. If there is no pictures then text "No picture found" should appear. Someone wrote VBA which I modified slightly but pictures are not showing.

Sub Load_Picture()


Dim Entry As Range
Dim WorkArea As Range
Dim Source As Worksheet


With Application
.ScreenUpdating = False
End With


Set Source = Sheets("Sheet1")
Set WorkArea = Source.Range(Cells(2, 2), Cells(Cells(Rows.Count, 2).End(xlUp).Row, 2))


For Each Entry In WorkArea
PicturePath = Dir("C:\Users\Public\Pictures\Sample Pictures" & ".jpg")
If PicturePath <> "" Then
Set Shp = ActiveSheet.Shapes.AddPicture(Filename:="C:\Users\Public\Pictures\Sample Pictures" & ".jpg" _
, LinkToFile:=False, SaveWithDocument:=True, Left:=Cells(Entry.Row, 1).Left, Top:=Cells(Entry.Row, 1).Top _
, Width:=Cells(Entry.Row, 1).Width, Height:=Cells(Entry.Row, 1).Height)
Shp.Placement = xlMoveAndSize
Shp.ControlFormat.PrintObject = True
Else
Entry.Offset(0, -1).Value = "Picture Not Found"
End If
Next Entry




End Sub
_______________________________

VBA does seem to work because it places "Pictures Not Found" in the column A for all B1-B3 values. But how to get the actual pictures in Column A? Is there something missing in the VBA?

Thank you for your help.

 

[yky]

I tested the code and it worked. Two problems I see are a) it always inserts the same picture, regardless the cell value, and b) it scales the picture to the cell, thus, distorted picture.

 

[jameslulu]

hello, NIHSCTEST.
This link may help you, the vba code can insert the images into the corresponding cells. it may replace the original cell values, so you need to make a copy for the original data. please try it.
https://www.extendoffice.com/documents/excel/2750-excel-replace-text-with-image-picture.html