Forum Discussion

samiaftb's avatar
samiaftb
Copper Contributor
Mar 28, 2022

Insert Picture from Folder (using URL) using Excel VBA

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?

excel
Macros and VBA

1 Reply

  • HansVogelaar's avatar
    HansVogelaar
    MVP
    Mar 28, 2022

    samiaftb 

    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

Resources