excel - 当用户编辑单元格时，为什么此 VBA Worksheet_Change 不会触发？

Question

我正在尝试创建一个宏，当用户在另一个单元格中输入特定信息时，该宏将图像插入一个单元格中。现在它正在工作，但不是立即。用户必须更改单元格，然后单击它，然后再打开。这是我的宏:

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

如有任何帮助，我们将不胜感激。非常感谢!

Answer 1

未经测试，但这应该能让您大致了解它是如何工作的:

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