Application.OnKey事件沒有執行

Question

當我按下「刪除」或「退格鍵」時沒有任何反應。
它應該清潔細胞。

Private Sub Worksheet_Change(ByVal Target As Range) 

Dim TestCell 
Dim RE As Object 
Dim REMatches As Object 
Dim Cell1_1 As String 
Dim Today As String 

ThisRow = Target.Row 

Application.OnKey "{DELETE}", "CleanCell1_1" 
Application.OnKey "{BACKSPACE}", "CleanCell1_1" 

If Target.Column = 10 Then 

Set RE = CreateObject("vbscript.regexp") 
With RE 
    .MultiLine = False 
    .Global = False 
    .IgnoreCase = True 
    .Pattern = "[G,g,Y,y,R,r]" 
End With 

For Each TestCell In Target.Cells 
    Set REMatches = RE.Execute(TestCell.Value) 
    If REMatches.Count > 0 Then 


    Today = Now() 

    Cell1_1 = Sheets("Input").Cells(1, 1).Value 
     Range("L" & ThisRow) = Cell1_1 + ": " + Format(Today, "ddmmmyy") 
     'MsgBox "Invalid:" & TestCell.Address & "-" & TestCell.Value 
     'TestCell.Value = "" 

    Else 
    MsgBox "Error" 
    End If 
Next 
End If 
End Sub 

Answer 1

1. 放置OnKey潛艇在一個單獨的模塊，並呼籲他們上Workbook_Open。他們將優先於Change事件
2. 當你犯了一個Change事件中的變化，您應該禁用事件 - 該代碼將重新調用自身

當前工作簿模塊

Private Sub Workbook_BeforeClose(Cancel As Boolean) 
Application.OnKey "{DELETE}" 
Application.OnKey "{BACKSPACE}" 
End Sub 

Private Sub Workbook_Open() 
Application.OnKey "{DELETE}", "CleanCell1_1" 
Application.OnKey "{BACKSPACE}", "CleanCell1_1" 
End Sub 

更新更改代碼

Private Sub Worksheet_Change(ByVal Target As Range) 

Dim TestCell 
Dim RE As Object 
Dim REMatches As Object 
Dim Cell1_1 As String 
Dim Today As String 
Dim rng1 As Range 

ThisRow = Target.Row 
Set rng1 = Intersect(Target, Columns("J")) 
If rng1 Is Nothing Then Exit Sub 

Application.EnableEvents = False 
Set RE = CreateObject("vbscript.regexp") 
With RE 
    .MultiLine = False 
    .Global = False 
    .IgnoreCase = True 
    .Pattern = "[G,g,Y,y,R,r]" 
End With 

For Each TestCell In rng1.Cells 
    Set REMatches = RE.Execute(TestCell.Value) 
    If REMatches.Count > 0 Then 

     Today = Now() 
     Cell1_1 = Sheets("Input").Cells(1, 1).Value 
     Range("L" & ThisRow) = Cell1_1 + ": " + Format(Today, "ddmmmyy") 
     'MsgBox "Invalid:" & TestCell.Address & "-" & TestCell.Value 
     'TestCell.Value = "" 
    Else 
     MsgBox "Error" 
    End If 
Next 
Application.EnableEvents = True 
End Sub