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?

1 Reply

  • 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