Excel VBA 宏进入无限循环 - 无法找到修复方法

Question

我正在尝试创建一个电子表格，其中用户找到与其姓名关联的正确的“到达”或“出发”单元格，输入空格（或其他字符），按回车键，当前时间（或时间/日期）为进入细胞内。以下是简单的电子表格。

Excel考勤记录

我创建了一个“更改事件”宏，以便当用户选择正确的单元格并进行更改（例如按空格键）然后返回或任何箭头键时，宏就会启动。宏是：

Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Range("C4:C11")) Is Nothing Then
    MsgBox "Cell " & Target.Address & " has changed."
    Target.Value = Now
End If
End Sub

结果是当前时间/日期被输入到所选的单元格中，但是，将时间/日期放入单元格中会创建一个“更改事件”，并且宏进入无限循环。 如何阻止宏进入无限循环 - 或者是否有更好的方法来实现所需的结果？

有人可以提出解决方案吗？

Answer 1

DoubleClick 之前的工作表：添加时间戳

简单

• 正如您评论中的 Chronocidal 所建议的，使用 Worksheet BeforeDoubleClick 事件更适合您的情况。

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
    
    ' Define constants.
    Const TARGET_RANGE_ADDRESS As String = "C4:D11"
    Dim TargetValue As Variant: TargetValue = Now
    
    ' Exit if no cell of the target range was double-clicked.
    If Intersect(Target, Me.Range(TARGET_RANGE_ADDRESS)) Is Nothing Then Exit Sub
    
    ' Exit edit mode.
    Cancel = True
    
    ' Write target value.
    Target.Value = TargetValue
    
End Sub

禁用事件

• 如果您想禁用事件，例如防止触发 Worksheet Change 事件或其他事件，您可以使用以下方法。
• 对于此事件来说，复杂性可能有点过大，但在处理 Worksheet Change 事件时可能会派上用场。

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
    
    ' Define constants.
    Const TARGET_RANGE_ADDRESS As String = "C4:D11"
    Dim TargetValue As Variant: TargetValue = Now
    Const DISABLE_EVENTS As Boolean = True
    
    ' Exit if no cell of the target range was double-clicked.
    If Intersect(Target, Me.Range(TARGET_RANGE_ADDRESS)) Is Nothing Then Exit Sub
    
    ' Exit edit mode.
    Cancel = True
    
    ' Write target value.
    If DISABLE_EVENTS Then
        WriteValueNoEvents Target, TargetValue
    Else
        Target.Value = TargetValue
    End If
    
End Sub

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose:      Disables events before writing a single value to each cell
'               of a range (in one go) and reenabling events.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Sub WriteValueNoEvents( _
        ByVal rg As Range, _
        ByVal Value As Variant)
    Dim ErrorMessage As String, WasErrorRaised As Boolean
    On Error GoTo ClearError ' start error-handling routine
        
    Application.EnableEvents = False
    rg.Value = Value
    
ProcExit:
    On Error Resume Next ' defer error trapping to prevent endless loop
        Application.EnableEvents = True
        If Not WasErrorRaised Then Exit Sub
        MsgBox ErrorMessage, vbCritical
    On Error GoTo 0 ' turn on error trapping
    Exit Sub
ClearError: ' continue error-handling routine
    ErrorMessage = "Run-time error [" & Err.Number & "]:" & vbLf & vbLf _
        & Err.Description
    WasErrorRaised = True
    Resume ProcExit
End Sub