Mar 27 2022 11:36 PM
Hi All,
I have a VBA code (see below) to insert a picture from folder located in My Computer. The code can insert the intended pictures however I have a problem that It keeps inserting the pictures when ever I make change or reopen the excel file.
I use this formula to insert in a specific cell ("=InsertPicFromURL(VLOOKUP(A11,Pictures,3))"), to call the Picture's location in A11 (Pictures' URL)
When ever the content of A11 is changes I want it to DELETE the previous Picture and insert new one as per the value in A11.
However, it keeps the previous Picture and inserts New and again If I make any change or save and reopen it will keep on inserting Picture.
How can I resolve this please?
Mar 28 2022 03:37 AM
Remove the formula(s).
Right-click the sheet tab.
Select 'View Code' from the context menu.
Copy the code listed below into the worksheet module.
I have used A11:A20 as the range of cells that should trigger inserting a picture. Change this as needed.
And I have used column D for the pictures. Also change this as needed.
Switch back to Excel.
Save the workbook as a macro-enabled workbook (*.xlsm).
Make sure that you allow macros when you open it.
Private Sub Worksheet_Change(ByVal Target As Range)
Dim rng1 As Range
Dim rng2 As Range
Dim cel As Range
Dim pic As Picture
Dim url As Variant
' Look for cells in A11:A20 that have been changed
Set rng1 = Intersect(Range("A11:A20"), Target)
If rng1 Is Nothing Then Exit Sub
Application.ScreenUpdating = False
' Pictures are in column D (3 columns to the right of column A)
Set rng2 = rng1.Offset(0, 3)
' Delete all pictures in rng2
For Each pic In Me.Pictures
If Not Intersect(pic.TopLeftCell, rng2) Is Nothing Then
pic.Delete
End If
Next pic
' Loop through the changed cells
For Each cel In rng1
If cel.Value <> "" Then
url = Application.VLookup(cel.Value, Range("Pictures"), 3, False)
If Not IsError(url) Then
With Me.Pictures.Insert(url)
.Top = cel.Top + 1
.Left = cel.Left + 1
.Height = Application.Max(cel.Height, cel.Width) + 2
.Width = Application.MaxC(cel.Width, .Width) + 2
End With
End If
End If
Next cel
Application.ScreenUpdating = True
End Sub