VBA Insert Image Code Is not working for me ?

[wangxiquang123]

Hello, I have a file coding VBA for inserting Image on excel. But it is not working, anything was wrong here ? pls help me fix them. Thank you so much ^^

Private Sub Worksheet_Change(ByVal Target As Range)
Dim Rng As Range, PicName As String, PicName2 As String, PicName3 As String, PicName4 As String
Application.ScreenUpdating = False
On Error Resume Next
If Not Intersect([E8], Target) Is Nothing Then
Set Rng = Sheet3.Range(Sheet3.[A1], Sheet3.[P65536].End(xlUp))
PicName = Rng.Resize(, 1).Find(Target, LookAt:=xlWhole).Offset(, 11)
PicName2 = Rng.Resize(, 1).Find(Target, LookAt:=xlWhole).Offset(, 12)
PicName3 = Rng.Resize(, 1).Find(Target, LookAt:=xlWhole).Offset(, 13)
PicName4 = Rng.Resize(, 1).Find(Target, LookAt:=xlWhole).Offset(, 14)
PicName5 = Rng.Resize(, 1).Find(Target, LookAt:=xlWhole).Offset(, 15)
PicName6 = Rng.Resize(, 1).Find(Target, LookAt:=xlWhole).Offset(, 16)
ActiveSheet.Shapes("aPic").Delete
With ActiveSheet.Pictures.Insert(ThisWorkbook.Path & "\" & PicName)
.Name = "aPic"
.Left = [A108:I122].Left: .Top = [A108:I122].Top
.Width = [A108:I122].Width: .Height = [A108:I122].Height
End With
ActiveSheet.Shapes("bPic").Delete
With ActiveSheet.Pictures.Insert(ThisWorkbook.Path & "\" & PicName2)
.Name = "bPic"
.Left = [F108:I122].Left: .Top = [F108:I122].Top
.Width = [F108:I122].Width: .Height = [F108:I122].Height
End With
ActiveSheet.Shapes("cPic").Delete
With ActiveSheet.Pictures.Insert(ThisWorkbook.Path & "\" & PicName3)
.Name = "cPic"
.Left = [A125:I139].Left: .Top = [A125:I139].Top
.Width = [A125:I139].Width: .Height = [A125:I139].Height
End With
ActiveSheet.Shapes("dPic").Delete
With ActiveSheet.Pictures.Insert(ThisWorkbook.Path & "\" & PicName4)
.Name = "dPic"
.Left = [F125:I139].Left: .Top = [F125:I139].Top
.Width = [F125:I139].Width: .Height = [F125:I139].Height
End With
ActiveSheet.Shapes("ePic").Delete
With ActiveSheet.Pictures.Insert(ThisWorkbook.Path & "\" & PicName5)
.Name = "ePic"
.Left = [A142:I156].Left: .Top = [A142:I156].Top
.Width = [A142:I156].Width: .Height = [A142:I156].Height
End With
ActiveSheet.Shapes("fPic").Delete
With ActiveSheet.Pictures.Insert(ThisWorkbook.Path & "\" & PicName6)
.Name = "fPic"
.Left = [F142:I156].Left: .Top = [F142:I156].Top
.Width = [F142:I156].Width: .Height = [F142:I156].Height
End With
End If
End Sub

 

[DanteAmor]

Hi @wangxiquang123 . Welcome to the MrExcel forum. Please accept my warmest greetings and sincere hope that all is well.

You should not use this statement: "On Error Resume Next" for all your code, as different types of errors can occur and you will not be able to know what the problem is.

Try the following, if you get an error, write the error message here and which line of the macro it stops on.

Before running the macro, verify that the image files exist in the folder where you have the file with the macro.

Private Sub Worksheet_Change(ByVal Target As Range)
  Dim f As Range
  Dim PicName1 As String, PicName2 As String, PicName3 As String
  Dim PicName4 As String, PicName5 As String, PicName6 As String
  
  Application.ScreenUpdating = False
  
  If Not Intersect([E8], Target) Is Nothing Then
    Set f = Sheet3.Range("A:A").Find(Target.Value, , xlValues, xlWhole, , , False)
    If Not f Is Nothing Then
      PicName1 = f.Offset(, 11).Value
      PicName2 = f.Offset(, 12).Value
      PicName3 = f.Offset(, 13).Value
      PicName4 = f.Offset(, 14).Value
      PicName5 = f.Offset(, 15).Value
      PicName6 = f.Offset(, 16).Value
      
      On Error Resume Next
        ActiveSheet.Shapes("aPic").Delete
        ActiveSheet.Shapes("bPic").Delete
        ActiveSheet.Shapes("cPic").Delete
        ActiveSheet.Shapes("dPic").Delete
        ActiveSheet.Shapes("ePic").Delete
        ActiveSheet.Shapes("fPic").Delete
      On Error GoTo 0
      
      With ActiveSheet.Pictures.Insert(ThisWorkbook.Path & "\" & PicName1)
        .Name = "aPic"
        .Left = [A108:I122].Left: .Top = [A108:I122].Top
        .Width = [A108:I122].Width: .Height = [A108:I122].Height
      End With
      
      With ActiveSheet.Pictures.Insert(ThisWorkbook.Path & "\" & PicName2)
        .Name = "bPic"
        .Left = [F108:I122].Left: .Top = [F108:I122].Top
        .Width = [F108:I122].Width: .Height = [F108:I122].Height
      End With
  
      With ActiveSheet.Pictures.Insert(ThisWorkbook.Path & "\" & PicName3)
        .Name = "cPic"
        .Left = [A125:I139].Left: .Top = [A125:I139].Top
        .Width = [A125:I139].Width: .Height = [A125:I139].Height
      End With
  
      With ActiveSheet.Pictures.Insert(ThisWorkbook.Path & "\" & PicName4)
        .Name = "dPic"
        .Left = [F125:I139].Left: .Top = [F125:I139].Top
        .Width = [F125:I139].Width: .Height = [F125:I139].Height
      End With
      
      With ActiveSheet.Pictures.Insert(ThisWorkbook.Path & "\" & PicName5)
        .Name = "ePic"
        .Left = [A142:I156].Left: .Top = [A142:I156].Top
        .Width = [A142:I156].Width: .Height = [A142:I156].Height
      End With
      
      With ActiveSheet.Pictures.Insert(ThisWorkbook.Path & "\" & PicName6)
        .Name = "fPic"
        .Left = [F142:I156].Left: .Top = [F142:I156].Top
        .Width = [F142:I156].Width: .Height = [F142:I156].Height
      End With
    Else
      MsgBox "Dont exists"
    End If
  End If
End Sub

----- --
I hope to hear from you soon.
Respectfully
Dante Amor
----- --

 

[DanteAmor]

Try this shortened version and comment if there are any errors, what the error message says, and which line of the macro it stops at.

Private Sub Worksheet_Change(ByVal Target As Range)
  Dim f As Range, rng As Range
  Dim PicName1 As String
  Dim arr As Variant
  Dim j As Long, col As Long
  
  Application.ScreenUpdating = False
  arr = Array("", "aPic", "A108:I122", "bPic", "F108:I122", "cPic", "A125:I139", _
                 "dPic", "F125:I139", "ePic", "A142:I156", "fPic", "F142:I156")
  col = 11
  If Not Intersect([E8], Target) Is Nothing Then
    Set f = Sheet3.Range("A:A").Find(Target.Value, , xlValues, xlWhole, , , False)
    If Not f Is Nothing Then
      For j = 1 To UBound(arr) Step 2
        On Error Resume Next: ActiveSheet.Shapes(arr(j)).Delete: On Error GoTo 0
        
        PicName1 = f.Offset(, col).Value
        Set rng = Range(arr(j + 1))
        With ActiveSheet.Pictures.Insert(ThisWorkbook.Path & "\" & PicName1)
          .Name = arr(j)
          .Left = rng.Left: .Top = rng.Top: .Width = rng.Width: .Height = rng.Height
        End With
        col = col + 1
      Next
    Else
      MsgBox "Dont exists"
    End If
  End If
End Sub

----- --
I hope to hear from you soon.
Respectfully
Dante Amor
----- --