如何根据单元格值动态插入图像

Question

I have two column

A         B

Cat
Lion

Pictures are in c:\\pictures folder and are in png format.I have wrote code like this

Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, [A:A]) Is Nothing Then Exit Sub
If Target.Row Mod 20 = 0 Then Exit Sub
On Error GoTo son
ActiveSheet.Pictures.Insert(ThisWorkbook.Path & "\" & Target.Value & ".jpg").Select
Selection.Top = Target.Offset(0, 2).Top
Selection.Left = Target.Offset(0, 4).Left
Selection.ShapeRange.LockAspectRatio = msoFalse
Selection.ShapeRange.Height = Target.Offset(0, 2).Height
Selection.ShapeRange.Width = Target.Offset(0, 2).Width
Target.Offset(1, 0).Select
son:

End Sub

The formula works fine. But when i delete value of A2 or A3 , correspoding picutres did not deleted . And When I again write the item in A2 and A3, Pictures add above old pictures.

Also is there any way to delete picture if the values of cells A2 and A3 are empty?

Answer 1

edited to handle picture absence/presence before adding/deleting it

you could name pictures with its parent cell address so that it's easy to reference them once you delete some parent cell content:

Private Sub Worksheet_Change(ByVal target As Range)
    If Intersect(target, [A:A]) Is Nothing Then Exit Sub
    If target.row Mod 20 = 0 Then Exit Sub

    If Not IsEmpty(target) Then '<--| if changed cell content is not empty
        If Not IsPicture(target) Then '<--| if there's not a picture whose name matches the target address
            With Pictures.Insert("C:\Users\chojwa\Desktop\a\UT\VARIE\software\VBA programming\Forum\Stack Overflow\images" & "\" & target.Value & ".bmp") '<--| insert it
                .Top = target.Offset(0, 2).Top
                .Left = target.Offset(0, 4).Left
                .ShapeRange.LockAspectRatio = msoFalse
                .ShapeRange.Height = target.Offset(0, 2).Height
                .ShapeRange.Width = target.Offset(0, 2).Width
                .name = target.Address '<--| associate the picture to the edited cell via its address
            End With
        End If
    Else '<--| if cell content has been deleted
        If IsPicture(target) Then Me.Shapes(target.Address).Delete '<--| delete the picture whose name is associated to the cell via its address, if any
    End If
    target.Offset(1, 0).Select
son:
End Sub

Function IsPicture(target As Range) As Boolean
    On Error Resume Next
    IsPicture = Not Shapes(target.Address) Is Nothing
    On Error GoTo 0
End Function