Question

当我按＆＃34;删除＆＃34;没有任何反应或＆＃34;退格＆＃34;。
它应该清洁细胞。

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

将OnKey个潜点放在单独的模块中，并在Workbook_Open上调用它们。他们将优先于Change事件
您应该在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

Application.OnKey事件未执行

1 个答案: