Why is this VBA Worksheet_Change not firing when a cell is edited by the user?

user_19111240 0
Viewed 65

I am trying to create a macro that inserts an image into one cell when the user enters specific information into an other cell. Right now it's working but not right away. The user has to change the cell then click off of it and then back on. Here is my macro:

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim KeyCells As Range
    Set KeyCells = Range("b7:f7,b13:f13,b19:f19,b25:f25,b31:f31,b37:f37")
    Dim myPict As Picture
    Dim ws As Worksheet
    ActiveCell.NumberFormat = "@"
    Dim curcell As Range
    Set curcell = ActiveWindow.ActiveCell.Offset(-3, 0)
    Dim PictureLoc As String
    PictureLoc = "C:\Users\WPeter\Desktop\VBA_TEST\test\" & ActiveCell.Text & ".jpeg"
If Not Intersect(KeyCells, Range(Target.Address)) Is Nothing Then
    For Each sh In ActiveSheet.Shapes
        If sh.TopLeftCell.Address = curcell.Address Then sh.Delete
    Next
        With ActiveCell.Offset(-3, 0)
        
        On Error GoTo errormessage:
        Set myPict = ActiveSheet.Pictures.insert(PictureLoc)
         myPict.Height = 119
         myPict.Width = 119
         myPict.Top = .Top + .Height / 2 - myPict.Height / 2
         myPict.Left = .Left + .Width / 2 - myPict.Width / 2
         myPict.Placement = xlMoveAndSize
errormessage:
        If Err.Number = 1004 Then
        MsgBox "File does not Exist, Please first update photo with .jpg File"
        End If
        End With

End If
End Sub

Any help would be appreciated. Thanks so much!

vba excel
2 Answers

Untested but this should give you a rough idea of how it could work:

Private Sub Worksheet_Change(ByVal Target As Range)

    Const FLDR = "C:\Users\WPeter\Desktop\VBA_TEST\test\"
    Dim KeyCells As Range, myPict As Picture, cPic As Range
    Dim c As Range, rng As Range, PictureLoc As String
    
    Set KeyCells = Range("b7:f7,b13:f13,b19:f19,b25:f25,b31:f31,b37:f37")
    Set rng = Application.Intersect(Target, KeyCells)
    If rng Is Nothing Then Exit Sub
    
    RemovePics rng.Offset(-3, 0) 'remove any existing shapes for this range
    
    For Each c In rng.Cells  'check each chsnged cell in the monitored range
        c.Font.Color = vbRed
        c.NumberFormat = "@"
        PictureLoc = FLDR & c.text & ".jpeg"
        If Len(Dir(PictureLoc)) > 0 Then   'does the file exist?
            Set cPic = c.Offset(-3, 0)     'picture destination cell
            With Me.Pictures.Insert(PictureLoc)
                .Height = 119
                .Width = 119
                .Top = cPic.Top + cPic.Height / 2 - .Height / 2
                .Left = cPic.Left + cPic.Width / 2 - .Width / 2
                .Placement = xlMoveAndSize
            End With
            c.Font.Color = vbBlack
        Else
            c.Font.Color = vbRed 'flag file not found (or use msgbox)
        End If
    Next c
End Sub

'remove any shape whose topleftcell intersects with range `rng`
Sub RemovePics(rng As Range)
    Dim i As Long
    For i = Me.Shapes.Count To 1 Step -1 'step backwards if deleting
        With Me.Shapes(i)
            If Not Application.Intersect(.TopLeftCell, rng) Is Nothing Then .Delete
        End With
    Next i
End Sub
user_4788840

Thank you all for your help. There seemed to be a list of things I was doing g incorrectly (Including using Target instead of ActiveCell) but I finally got it to work. This is my current code

Function IsFile(ByVal fName As String) As Boolean
'Returns TRUE if the provided name points to an existing file.
'Returns FALSE if not existing, or if it's a folder
    On Error Resume Next
    IsFile = ((GetAttr(fName) And vbDirectory) <> vbDirectory)
End Function
Private Sub Worksheet_Change(ByVal Target As Range)
Dim KeyCells As Range
Set KeyCells = Range("b7:e7,b13:e13,b19:e19,b25:e25,b31:e31,b37:e37")
Dim PictureLoc As String
Dim myPict As Picture
Dim ws As Worksheet
Target.NumberFormat = "@"
Dim imgcell As Range
Set imgcell = Target.Offset(-3, 0)
If Not Application.Intersect(KeyCells, Range(Target.Address)) Is Nothing Then
    For Each sh In ActiveSheet.Shapes
        If sh.TopLeftCell.Address = imgcell.Address Then sh.Delete
    Next
    If IsFile("\\amer.turck.info\data\Plymouth\Marketing\Asim Connectivity Image Project\Vending_poster\images\" & Target.Text & ".jpeg") = True Then
    PictureLoc = "\\amer.turck.info\data\Plymouth\Marketing\Asim Connectivity Image Project\Vending_poster\images\" & Target.Text & ".jpeg"
    ElseIf IsFile("\\amer.turck.info\data\Plymouth\Marketing\Asim Connectivity Image Project\Vending_poster\images\" & Target.Text & ".jpg") = True Then
    PictureLoc = "\\amer.turck.info\data\Plymouth\Marketing\Asim Connectivity Image Project\Vending_poster\images\" & Target.Text & ".jpg"
    ElseIf IsFile("\\amer.turck.info\data\Plymouth\Marketing\Asim Connectivity Image Project\Vending_poster\images\" & Target.Text & ".png") = True Then
    PictureLoc = "\\amer.turck.info\data\Plymouth\Marketing\Asim Connectivity Image Project\Vending_poster\images\" & Target.Text & ".png"
    End If
        With imgcell
        
        On Error GoTo errormessage:
        Set myPict = ActiveSheet.Pictures.Insert(PictureLoc)
         myPict.Height = 119
         myPict.Width = 119
            If myPict.Height > 119 Then
            myPict.Height = 119
            End If
         myPict.Top = .Top + .Height / 2 - myPict.Height / 2
         myPict.Left = .Left + .Width / 2 - myPict.Width / 2
         myPict.Placement = xlMoveAndSize
errormessage:
        If Err.Number = 1004 Then
        MsgBox "File does not Exist, Please first update photo with .jpg File"
        End If
        End With
End If
End Sub

Also I apologize if this request was messy or disorganized. It is my first time posting on Stackoverflow/

user_191112400
Related