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

Question

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!

Answer 1

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

Answer 2

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/