Private Sub Worksheet_Change(ByVal Target As Range)
Dim p$, fn$, s As Shape, r As Range, c As Range, j As Range
Dim a, e
Set r = Intersect(Columns("H:H"), Target)
If r Is Nothing Then Exit Sub
If r.Column <> 8 Then Exit Sub 'Column H=8
p = CreateObject("WScript.Shell").SpecialFolders("Desktop") & "\Image\"
'https://support.office.com/en-us/article/graphic-file-types-you-can-insert-and-save-dad53574-3384-4ced-b472-348d37c326a7
'https://en.wikipedia.org/wiki/Image_file_formats
a = Split("jpg,gif,bmp,png,tif,tiff", ",")
Application.EnableEvents = False
Application.ScreenUpdating = False
Application.DisplayAlerts = False
For Each c In r
For Each e In a
fn = p & c & "." & e
If Dir(fn) <> "" Then
Exit For
Else
fn = ""
End If
Next e
On Error Resume Next
ActiveSheet.Shapes("Pic" & c.Address(False, False)).Delete
On Error GoTo 0
If fn <> "" Then
Set j = Cells(c.Row, "J")
j.RowHeight = 80
'Set s = ActiveSheet.Shapes.AddPicture( _
fn, msoFalse, msoCTrue, j.Left, j.Top, j.Width, j.Height)
Set s = ActiveSheet.Shapes.AddPicture( _
fn, msoFalse, msoCTrue, j.Left, j.Top, 70, 80)
s.Name = "Pic" & c.Address(False, False)
End If
Next c
Application.DisplayAlerts = True
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub