VBA code to insert image to cell based on cell value

Question

Dears, I have a worksheet where i need to insert 1 or 2 images from a folder on my pc to the Excel file based on cell value

i need to insert image in cell (H43) based on the value in cell (E5) and the other image in cell (L43) baded on the value in cell (G5) and if E5 or G5 is blank to keep the other cell blank and this is my folder source "D:\Desktop\Guards\Guards National IDs" N.B. i have all images also created as hyberlinks on other sheet if this will help (I'm using office 2021)

i have found a code on internet but only can insert one image not two please help me as I'm new to the vba code

thank you dears in advance for help and here is the code i have

Private Sub Worksheet_Change(ByVal Target As Range)
Dim picname As String
Dim pic As Object
Dim source As String

Dim t, l, h, w As Integer

source = Range("H43").Value
picname = "Picture 2"
Set pic = ActiveSheet.Shapes(picname)

With pic
t = .Top
l = .Left
h = .Height
w = .Width

End With

ActiveSheet.Shapes(picname).Delete

Set pic = ActiveSheet.Shapes.AddPicture(source, False, True, l, t, w, h)

pic.Name = picname

End Sub


please modify the code to insert 2 images not one

Answer 1

By

if E5 or G5 is blank to keep the other cell blank

I'm assuming you mean if E5 is cleared then make sure Picture 1 doesn't exist and if G5 is cleared then make sure Picture 2 doesn't exist (though a commented out line is included to use if you also want to clear the path values in H43 and L43). [Edit: I just noticed I'm mentioning blank shapes in the text in cells H43 and L43 - I considered then decided against using blanks as placeholders, but forgot to remove the extra text from the cells in the screenprints below; the text should have been something like: 'The path to picture 1 is stored in H43' and 'The path to picture 2 is stored in L43'.]

Let's say we're starting off with the following inside the worksheet:

Then changing E5 to a non-blank value adds Picture 1 based on the path in H43:

Changing G5 to a non-blank value also adds Picture 2 based on the path in L43:

Similarly, changing the values to blanks, removes the respective:

The code prints out the following for the four steps above:

Here's the code:

Sub Worksheet_Change(ByVal Target As Range)
    Dim ws As Worksheet, pic As Shape, a As Variant, r As Long
    Set ws = ThisWorkbook.ActiveSheet
    'Create a 2x3/multidimensional array using the Application.Evaluate [] shortcut.
    a = [{"Picture 1","E5","H43"; "Picture 2","G5","L43"}] 'The array contains pic: names, cond. & path rngs

    For r = LBound(a) To UBound(a)
        If Target.Address(0, 0) = a(r, 2) Then
            Debug.Print "Potential edit in sheet: " & ws.Name & " cell: " & Target.Address(0, 0)
            If Target.Value <> "" Then 'delete old pic insert new one
                Debug.Print " Del old if exists & Add the new: " & a(r, 1) & " into cell: " & a(r, 3)
                On Error GoTo AddShapeHandler
                Debug.Print " (" & ws.Shapes(a(r, 1)).Name & " exists, deleting)" 'checking if pic exists
                ws.Shapes(a(r, 1)).Delete
AddShapeHandler:
                Debug.Print " " & a(r, 1) & " does not exit, a new one will be added"
                ws.Range(a(r, 3)).Select
                'might be a good idea to check if path is valid/picture file is in the folder
                Set pic = ws.Shapes.AddPicture(ws.Range(a(r, 3)).Value, False, True, ws.Range(a(r, 3)).Left, ws.Range(a(r, 3)).Top, -1, -1)
                pic.Name = a(r, 1)
                Exit For
            Else
                Debug.Print " Del old if exists: " & a(r, 1) & " and optionally clear cell: " & a(r, 3)
                On Error GoTo DelShapeHandler
                Debug.Print " (" & ws.Shapes(a(r, 1)).Name & " exists, deleting)" 'checking if pic exists
                ws.Shapes(a(r, 1)).Delete
DelShapeHandler:
'                ws.Range(a(r, 3)).ClearContents 'uncomment if you want to also delete the path
                Exit For
            End If
        End If
    Next
End Sub

Here's the code with the hardcoded path per your comments below (remember to change picture1.png and picture2.png file names in the array called 'a' if your file names are different):

Sub Worksheet_Change(ByVal Target As Range)
    Dim ws As Worksheet, pic As Shape, a As Variant, r As Long, path As String
    Set ws = ThisWorkbook.ActiveSheet
    path = "D:\Desktop\Guards\Guards National IDs\"
    'The array below contains picture names, condition ranges, add-to ranges, _
        and file names for pictures 1 and 2 (e.g. picture1.png - please edit these to match your file names)
    a = [{"Picture 1","E5","H43","picture1.png"; "Picture 2","G5","L43","picture1.png"}] 'Create a 2x4/multidimensional array using the Application.Evaluate [] shortcut.

    For r = LBound(a) To UBound(a)
        If Target.Address(0, 0) = a(r, 2) Then
            Debug.Print "Potential edit in sheet: " & ws.Name & " cell: " & Target.Address(0, 0)
            If Target.Value <> "" Then 'delete old pic insert new one
                Debug.Print " Del old if exists & Add the new: " & a(r, 1) & " into cell: " & a(r, 3)
                On Error GoTo AddShapeHandler
                Debug.Print " (" & ws.Shapes(a(r, 1)).Name & " exists, deleting)" 'checking if pic exists
                ws.Shapes(a(r, 1)).Delete
AddShapeHandler:
                Debug.Print " (Adding a new " & a(r, 1) & ")"
                ws.Range(a(r, 3)).Select
                'might be a good idea to check if path is valid/picture file is in the folder
                path = path & a(r, 4)
                Set pic = ws.Shapes.AddPicture(path, False, True, ws.Range(a(r, 3)).Left, ws.Range(a(r, 3)).Top, -1, -1) '-1,-1 simply uses the picture's original Width and Height respectively
                pic.Name = a(r, 1)
                Exit For
            Else
                Debug.Print " Del old if exists: " & a(r, 1) & " and optionally clear cell: " & a(r, 3)
                On Error GoTo DelShapeHandler
                Debug.Print " (" & ws.Shapes(a(r, 1)).Name & " exists, deleting)" 'checking if pic exists
                ws.Shapes(a(r, 1)).Delete
DelShapeHandler:
                ws.Range(a(r, 3)).ClearContents 'comment-out if you want keep the existing contents in cells H43, L43
                Exit For
            End If
        End If
    Next
End Sub

Here are the additional updates to the code per your comments below:

'Added a function called picPath for path checking and searching for a picture by name (excluding extension; picture names are hardcoded in the 'a' array)
Sub Worksheet_Change(ByVal Target As Range)
    Dim ws As Worksheet, pic As Shape, a As Variant, r As Long, path As String
    Set ws = ThisWorkbook.ActiveSheet
    path = "D:\Desktop\Guards\Guards National IDs\"
    'The array below contains picture file names without extensions (because extensions may vary), condition ranges, and add-to ranges, _
        (please make sure file names picture001 and picture002 in the array below correspond to the file names in your folder)
    a = [{"picture001","E5","D44"; "picture002","G5","J44"}] 'Create a 2x3/multidimensional array using the Application.Evaluate [] shortcut.

    For r = LBound(a) To UBound(a)
        If Target.Address(0, 0) = a(r, 2) Then 'consider using If Not Intersect(Target, Range("E5,G5") or Range("E5:G5")) Is Nothing Then...with other changes in the code if you want to change multiple conditions in one swoop
            Debug.Print "Potential edit in sheet: " & ws.Name & " cell: " & Target.Address(0, 0)
            If Target.Value <> "" Then 'delete old pic insert new one
                Debug.Print " Del old if exists & Add the new: " & a(r, 1) & " into cell: " & a(r, 3)
                On Error GoTo AddShapeHandler
                Debug.Print " (" & ws.Shapes(a(r, 1)).Name & " exists, deleting)" 'checking if pic exists
                ws.Shapes(a(r, 1)).Delete
AddShapeHandler:
                Debug.Print " (Adding a new " & a(r, 1) & ")"
                ws.Range(a(r, 3)).Select
                path = picPath(path, a(r, 1))
                If Len(path) < 2 Then Exit Sub 'either the path is invalid or the picture wasn't found by name in the array called 'a'
                Set pic = ws.Shapes.AddPicture(path, False, True, ws.Range(a(r, 3)).Left, ws.Range(a(r, 3)).Top, -1, -1) '-1,-1 simply uses the picture's original Width and Height respectively
                pic.Name = a(r, 1)
                Exit For
            Else
                Debug.Print " Del old if exists: " & a(r, 1) & " and optionally clear cell: " & a(r, 3)
                On Error GoTo DelShapeHandler
                Debug.Print " (" & ws.Shapes(a(r, 1)).Name & " exists, deleting)" 'checking if pic exists
                ws.Shapes(a(r, 1)).Delete
DelShapeHandler:
'                ws.Range(a(r, 3)).ClearContents 'comment-out if you want keep the existing contents in cells D44, J44
                Exit For
            End If
        End If
    Next
End Sub

Function picPath(path As String, picName As Variant) As String
    Dim fso, file, files, folder As Object
    Set fso = CreateObject("Scripting.FileSystemObject")
    
    If fso.FolderExists(path) Then 'Path is valid/folder exists
        Set folder = fso.GetFolder(path)
        Set files = folder.files
        If files.Count = 0 Then 'Folder is empty
            Debug.Print " (exiting sub): 0 files in " & path
            picPath = 0: Exit Function 'return 0
        End If
        For Each file In files
            Debug.Print "   (found the following file: " & file.Name & " in " & path & ")"
            If InStr(file.Name, picName) Then 'InStr(look_inside, look_for)
                Debug.Print " ([Success] found: " & picName & " in " & path & ")"
                picPath = file.path: Exit Function 'return picture's path
            End If
        Next
    Else
        Debug.Print " (exiting sub): Didn't find picName: " & picName & " in " & path
        picPath = 0: Exit Function 'return 0
    End If
End Function

Here's the update per your latest comment (numbers in E5,G5 correlate to picture file names - the code searches the folder from the path String for a file containing the corresponding number in it's name): Code:

'Essentially only changed 'path = picPath(path, a(r, 1))' to 'path = picPath(path, ws.Range(a(r, 2)).Value)'
'some minor format changes (shape names, Debug.Prints)
Sub Worksheet_Change(ByVal Target As Range)
    Dim ws As Worksheet, pic As Shape, a As Variant, r As Long, path As String
    Set ws = ThisWorkbook.ActiveSheet
    path = "D:\Desktop\Guards\Guards National IDs\"
    'The array below contains picture shape names, condition ranges (numbers in which correlate to picture file names), and add-to ranges
    a = [{"picture1","E5","D44"; "picture2","G5","J44"}] 'Create a 2x3/multidimensional array using the Application.Evaluate [] shortcut.

    For r = LBound(a) To UBound(a)
        If Target.Address(0, 0) = a(r, 2) Then 'consider using If Not Intersect(Target, Range("E5,G5") or Range("E5:G5")) Is Nothing Then...with other changes in the code if you want to change multiple conditions in one swoop
            Debug.Print "Potential edit in sheet: " & ws.Name & " cell: " & Target.Address(0, 0)
            If Target.Value <> "" Then 'delete old pic insert new one
                Debug.Print " (Del old if exists, Add the new: " & a(r, 1) & " into cell: " & a(r, 3) & ")"
                On Error GoTo AddShapeHandler
                Debug.Print " (" & ws.Shapes(a(r, 1)).Name & " exists, deleting)" 'checking if pic exists
                ws.Shapes(a(r, 1)).Delete
AddShapeHandler:
                Debug.Print " (Adding the new " & a(r, 1) & ")"
                ws.Range(a(r, 3)).Select
                path = picPath(path, ws.Range(a(r, 2)).Value)
                If Len(path) < 2 Then Exit Sub 'either the path is invalid or the picture file which name contains ws.Range(a(r, 1)).Value wasn't found
                Set pic = ws.Shapes.AddPicture(path, False, True, ws.Range(a(r, 3)).Left, ws.Range(a(r, 3)).Top, -1, -1) '-1,-1 simply uses the picture's original Width and Height respectively
                pic.Name = a(r, 1)
                Exit For
            Else
                Debug.Print " (Del old if exists: " & a(r, 1) & " and optionally clear cell: " & a(r, 3) & ")"
                On Error GoTo DelShapeHandler
                Debug.Print " (" & ws.Shapes(a(r, 1)).Name & " exists, deleting)" 'checking if pic exists
                ws.Shapes(a(r, 1)).Delete
DelShapeHandler:
'                ws.Range(a(r, 3)).ClearContents 'comment-out if you want keep the existing contents in cells D44, J44
                Exit For
            End If
        End If
    Next
End Sub

Function picPath(path As String, picName As Variant) As String
    Dim fso, file, files, folder As Object
    Set fso = CreateObject("Scripting.FileSystemObject") 'consider using dir() instead of fso
    Debug.Print "  [searching for a picture which name contains: " & picName & " in path: " & path & "]"
    If fso.FolderExists(path) Then 'Path is valid/folder exists
        Set folder = fso.GetFolder(path)
        Set files = folder.files
        If files.Count = 0 Then 'Folder is empty
            Debug.Print "  [(exiting sub): 0 files in " & path & "]"
            picPath = 0: Exit Function 'return 0
        End If
        For Each file In files
            Debug.Print "   [(found the following file: " & file.Name & " in " & path & ")]"
            If InStr(file.Name, picName) Then 'InStr(look_inside, look_for)
                Debug.Print "  [(success): found a picture which name contains: " & picName & " in " & path & "]"
                picPath = file.path: Exit Function 'return picture's path
            End If
        Next
    Else
        Debug.Print "  [(exiting sub): there is a syntax error in the path or the directory/folder doesn't exist, path: " & path & "]"
        picPath = 0: Exit Function 'return 0
    End If
End Function

Added dynamic resizing of picture shapes if the destination cells are merged. Also added base file name to more accurately/consistently match conditions to picture names:

Sub Worksheet_Change(ByVal Target As Range)
    Dim ws As Worksheet, pic As Shape, a As Variant, r As Long, path As String
    Set ws = ThisWorkbook.ActiveSheet
    path = "D:\Desktop\Guards\Guards National IDs\"
    Const base_name_pic = "picture" 'Assuming your picture files are named picture1.jpg, picture2.png and so on
    'The array below contains picture shape names, condition ranges (numbers in which correlate to picture file names), and add-to ranges
    a = [{"picture1","E5","D44"; "picture2","G5","J44"}] 'Create a 2x3/multidimensional array using the Application.Evaluate [] shortcut.

    For r = LBound(a) To UBound(a)
        If Target.Address(0, 0) = a(r, 2) Then 'consider using If Not Intersect(Target, Range("E5,G5") or Range("E5:G5")) Is Nothing Then...with other changes in the code if you want to change multiple conditions in one swoop
            Debug.Print "Potential edit in sheet: " & ws.Name & " cell: " & Target.Address(0, 0)
            If Target.Value <> "" Then 'delete old pic insert new one
                Debug.Print " (Del old if exists, Add the new: " & a(r, 1) & " into cell: " & a(r, 3) & ")"
                On Error GoTo AddShapeHandler
                Debug.Print " (" & ws.Shapes(a(r, 1)).Name & " exists, deleting)" 'checking if pic exists
                ws.Shapes(a(r, 1)).Delete
AddShapeHandler:
                Debug.Print " (Adding the new " & a(r, 1) & ")"
                path = picPath(path, base_name_pic, ws.Range(a(r, 2)).Value)
                If Len(path) < 2 Then Exit Sub 'either the path is invalid or the picture file which name contains ws.Range(a(r, 1)).Value wasn't found
                If ws.Range(a(r, 3)).MergeCells Then
                    Set pic = ws.Shapes.AddPicture(path, False, True, ws.Range(a(r, 3)).Left, ws.Range(a(r, 3)).Top, _
                        ws.Range(ws.Range(a(r, 3)).MergeArea.Address).Width, ws.Range(ws.Range(a(r, 3)).MergeArea.Address).Height)
                Else
                    Set pic = ws.Shapes.AddPicture(path, False, True, ws.Range(a(r, 3)).Left, ws.Range(a(r, 3)).Top, _
                        ws.Range(a(r, 3)).Width, ws.Range(a(r, 3)).Height) '-1,-1 simply uses the picture's original Width and Height respectively
                End If
                pic.Name = a(r, 1)
                Exit For
            Else
                Debug.Print " (Del old if exists: " & a(r, 1) & " and optionally clear cell: " & a(r, 3) & ")"
                On Error GoTo DelShapeHandler
                Debug.Print " (" & ws.Shapes(a(r, 1)).Name & " exists, deleting)" 'checking if pic exists
                ws.Shapes(a(r, 1)).Delete
DelShapeHandler:
'                ws.Range(a(r, 3)).ClearContents 'uncomment if you want clear the existing contents in cells D44, J44
                Exit For
            End If
        End If
    Next
End Sub

Function picPath(path, base_name_pic As String, picNum As Variant) As String
    Dim fso, file, files, folder As Object
    Set fso = CreateObject("Scripting.FileSystemObject") 'consider using dir() instead of fso
    Debug.Print "  [searching for a picture which name contains: " & base_name_pic & picNum & " in path: " & path & "]"
    If fso.FolderExists(path) Then 'Path is valid/folder exists
        Set folder = fso.GetFolder(path)
        Set files = folder.files
        If files.Count = 0 Then 'Folder is empty
            Debug.Print "  [(exiting sub): 0 files in " & path & "]"
            picPath = 0: Exit Function 'return 0
        End If
        For Each file In files
            Debug.Print "   [(found the following file: " & file.Name & " in " & path & ")]"
            If InStr(file.Name, base_name_pic & picNum) Then 'InStr(look_inside, look_for)
                Debug.Print "  [(success): found a picture which name contains: " & base_name_pic & picNum & " in " & path & "]"
                picPath = file.path: Exit Function 'return picture's path
            End If
        Next
    Else
        Debug.Print "  [(exiting sub): there is a syntax error in the path or the directory/folder doesn't exist, path: " & path & "]"
        picPath = 0: Exit Function 'return 0
    End If
End Function

Add date to D11 per your other question:

Sub Worksheet_Change(ByVal Target As Range)
    Dim ws As Worksheet, pic As Shape, a As Variant, r As Long, path As String
    Set ws = ThisWorkbook.ActiveSheet
    path = "D:\Desktop\Guards\Guards National IDs\"
    'The array below contains picture shape names, condition ranges (numbers in which correlate to picture file names), and add-to ranges
    a = [{"picture1","E5","D44"; "picture2","G5","J44"}] 'Create a 2x3/multidimensional array using the Application.Evaluate [] shortcut.

    For r = LBound(a) To UBound(a)
        If Target.Address(0, 0) = a(r, 2) Then 'consider using If Not Intersect(Target, Range("E5,G5") or Range("E5:G5")) Is Nothing Then...with other changes in the code if you want to change multiple conditions in one swoop
            ws.Range("D11").Value = Format(ThisWorkbook.BuiltinDocumentProperties("Last Save time"), "short date")
            Debug.Print "Potential edit in sheet: " & ws.Name & " cell: " & Target.Address(0, 0)
            If Target.Value <> "" Then 'delete old pic insert new one
                Debug.Print " (Del old if exists, Add the new: " & a(r, 1) & " into cell: " & a(r, 3) & ")"
                On Error GoTo AddShapeHandler
                Debug.Print " (" & ws.Shapes(a(r, 1)).Name & " exists, deleting)" 'checking if pic exists
                ws.Shapes(a(r, 1)).Delete
AddShapeHandler:
                Debug.Print " (Adding the new " & a(r, 1) & ")"
                path = picPath(path, ws.Range(a(r, 2)).Value)
                If Len(path) < 2 Then Exit Sub 'either the path is invalid or the picture file which name contains ws.Range(a(r, 1)).Value wasn't found
                If ws.Range(a(r, 3)).MergeCells Then
                    Set pic = ws.Shapes.AddPicture(path, False, True, ws.Range(a(r, 3)).Left, ws.Range(a(r, 3)).Top, _
                        ws.Range(ws.Range(a(r, 3)).MergeArea.Address).Width, ws.Range(ws.Range(a(r, 3)).MergeArea.Address).Height)
                Else
                    Set pic = ws.Shapes.AddPicture(path, False, True, ws.Range(a(r, 3)).Left, ws.Range(a(r, 3)).Top, _
                        ws.Range(a(r, 3)).Width, ws.Range(a(r, 3)).Height) '-1,-1 simply uses the picture's original Width and Height respectively
                End If
                pic.Name = a(r, 1)
                Exit For
            Else
                Debug.Print " (Del old if exists: " & a(r, 1) & " and optionally clear cell: " & a(r, 3) & ")"
                On Error GoTo DelShapeHandler
                Debug.Print " (" & ws.Shapes(a(r, 1)).Name & " exists, deleting)" 'checking if pic exists
                ws.Shapes(a(r, 1)).Delete
DelShapeHandler:
'                ws.Range(a(r, 3)).ClearContents 'uncomment if you want clear the existing contents in cells D44, J44
                Exit For
            End If
        End If
    Next
End Sub

Function picPath(path As String, picNum As Variant) As String
    Dim fso, file, files, folder As Object
    Set fso = CreateObject("Scripting.FileSystemObject") 'consider using dir() instead of fso
    Debug.Print "  [searching for a picture which name contains: " & picNum & " in path: " & path & "]"
    If fso.FolderExists(path) Then 'Path is valid/folder exists
        Set folder = fso.GetFolder(path)
        Set files = folder.files
        If files.Count = 0 Then 'Folder is empty
            Debug.Print "  [(exiting sub): 0 files in " & path & "]"
            picPath = 0: Exit Function 'return 0
        End If
        For Each file In files
            Debug.Print "   [(found the following file: " & file.Name & " in " & path & ")]"
            If InStr(file.Name, picNum) Then 'InStr(look_inside, look_for)
                Debug.Print "  [(success): found a picture which name contains: " & picNum & " in " & path & "]"
                picPath = file.path: Exit Function 'return picture's path
            End If
        Next
    Else
        Debug.Print "  [(exiting sub): there is a syntax error in the path or the directory/folder doesn't exist, path: " & path & "]"
        picPath = 0: Exit Function 'return 0
    End If
End Function