VBA Insert Picture Dynamically In Cell Based On Cell Value and do nothing if the cell is empty-CodePudding

I have a statement with Image Dynamically In Cell (fom I11 to I19) I usually only use 2 or 3 lines, so the other 7-8 are empty. My macro command works fine in cells that are filled, but for empty cells it also inserts an image that says "The linked image cannot be displayed". I would like VBA not to insert an image if cell D11 to D19 is empty. Also, to run the command I have to click on the developer tab and macros, can this be automated (column D has data validation)?. Thank you

Sub Insert_Multiple_Images()

Set Image_Names = Range("D11:D19")
Image_Location = "C:\Image"
Image_Format = ".png"

Set Cell_Reference = Range("I11:I19")

For i = 1 To Image_Names.Rows.Count
    For j = 1 To Image_Names.Columns.Count
        Set Image = ActiveSheet.Pictures.Insert(Image_Location   "\"   Image_Names.Cells(i, j)   Image_Format)
        Image.Top = Cell_Reference.Cells(i, j).Top
        Image.Left = Cell_Reference.Cells(i, j).Left
        Image.ShapeRange.Height = 45
        Image.ShapeRange.Width = 75
    Next j
Next i

End Sub

CodePudding user response：

Please, use the next solution. You did not answer the clarifications question, so it automatically run if any cell in range "D11:D19" is change. The code checks if a picture exists on the corresponding cell ("I & modified cell row), it is deleted. If after modification the cell is empty, the code does not do anything:

Please, copy the next code in the sheet you need to process code module (right click on the sheet name and choose View Code):

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim Image_Names As Range

    Set Image_Names = Range("D11:D19")
    If Not Intersect(Image_Names, Target) Is Nothing Then
        Dim Image_Location As String, Image_Format As String, i As Long, Image As Object
        Image_Location = "C:\Image"
        Image_Format = ".png"
        
        If Target.value <> "" Then 'if the changed cell is not empty:
                'check if picture exists:
                If Dir(Image_Location & "\" & Target.value & Image_Format) <> "" Then
                    'if picture already exists, delete it:
                    deletePicture Target.Offset(, 5).Address
                    
                    Set Image = Me.Pictures.Insert(Image_Location & "\" & Target.value & Image_Format)
                    Image.top = Target.Offset(, 5).top: Image.left = Target.Offset(, 5).left
                    
                    Image.ShapeRange.height = 45: Image.ShapeRange.width = 75
                Else
                    MsgBox "No picture exists on path """ & Image_Location & "\" & Target.value & Image_Format
                End If
        Else
            'if picture already exists, delete it:
            deletePicture Target.Offset(, 5).Address
       End if
    End If
End Sub

Sub deletePicture(rngAddr As String)
    Dim sh As Shape
    
    For Each sh In Me.Shapes
        If sh.Type = 11 Then 'to process only the necessary pictures...
            If sh.TopLeftCell.Address = rngAddr Then sh.Delete: Exit For
        End If
    Next sh
End Sub

Please, send some feedback after testing it.

The code can process all the range as your code does, but since nothing has been changed in the rest of the range, it will only be Excel wasting resources, I think.

CodePudding user response：

Could try using dynamic range for last row used in column D and column I and match the 2 ranges.

dim lRowD as integer

'find last row used and in worksheet 1 column D (column 4)' lRowD = Worksheets(1).Cells(Rows.Count, 4).End(xlUp).Row

'Update these lines' Set Image_Names = Range("D11:D" & lRowD) Set Cell_Reference = Range("I11:I" & lRowD)

Also, can go to insert -> shapes and right click menu on a shape and assign a macro rather than going to developer tab.