excel - 如何撤消在代码中完成的操作？对象 'Undo' 的方法 'Application' 失败

Question

我有两个依赖于应用程序事件的代码。
代码 (1) worksheet_SelectionChange使用日期选择器插入日期 Link

Private Sub worksheet_SelectionChange(ByVal Target As Excel.Range)
   If Not Intersect(Target, Range("M3:M100")) Is Nothing Then Call Basic_Calendar
End Sub

代码(2)Worksheet_Change记录 ActiveSheet 的任何单元格的更改并放入另一张表(“日志”)。
引发错误 :使用日期选择器插入任何值后

Method 'Undo' of object '_Application' failed

在 Application.Undo关于代码 (2)。
我尝试添加 If Target.Cells.CountLarge = 1正下方worksheet_SelectionChange事件，但同样的问题。

Private Sub Worksheet_Change(ByVal Target As Range)   'Log Changes of Current Sheet and put in Sheet("Log")

 Dim RangeValues As Variant, r As Long, boolOne As Boolean, TgValue  'the array to keep Target values (before UnDo)
 Dim SH As Worksheet: Set SH = Sheets("Log")
 Dim UN As String: UN = Application.UserName
 
 If Not Intersect(Target, Range("AK:XFD")) Is Nothing Then Exit Sub  'not doing anything if a cell in AK:XFD is changed
 
 Application.ScreenUpdating = False
 Application.Calculation = xlCalculationManual
 
 If Target.Cells.Count > 1 Then
    TgValue = ExtractData(Target)
 Else
    TgValue = Array(Array(Target.value, Target.Address(0, 0)))  'Put the target range in an array (or as a string for a single cell)
    boolOne = True
 End If
 
 Application.EnableEvents = False               'Avoide trigger the change event after UnDo
     Application.Undo
     RangeValues = ExtractData(Target)          'Define RangeValue
     PutDataBack TgValue, ActiveSheet           'Put back the changed data
     If boolOne Then Target.Offset(1).Select
 Application.EnableEvents = True

 Dim columnHeader As String, rowHeader As String
 
 For r = 0 To UBound(RangeValues)
    If RangeValues(r)(0) <> TgValue(r)(0) Then
        columnHeader = Cells(1, Range(RangeValues(r)(1)).Column).value
        rowHeader = Range("B" & Range(RangeValues(r)(1)).Row).value
        
        Sheets("Log").Range("A" & Rows.Count).End(xlUp).Offset(1, 0).Resize(1, 6).value = _
            Array(UN, Now, rowHeader, columnHeader, TgValue(r)(0), RangeValues(r)(0))
    End If
 Next r
 
  Application.ScreenUpdating = True
  Application.Calculation = xlCalculationAutomatic
          
End Sub


Sub PutDataBack(arr, SH As Worksheet)
    Dim i As Long, arrInt, El
    For Each El In arr
        SH.Range(El(1)).value = El(0)
    Next
End Sub


Function ExtractData(Rng As Range) As Variant
    Dim a As Range, arr, Count As Long, i As Long
    ReDim arr(Rng.Cells.Count - 1)
    For Each a In Rng.Areas 'creating a jagged array containing the values and the cells address
        For i = 1 To a.Cells.Count
            arr(Count) = Array(a.Cells(i).value, a.Cells(i).Address(0, 0)): Count = Count + 1
        Next
    Next
    ExtractData = arr
End Function

Answer 1

请复制下一个代码而不是现有代码(在包含 Basic_Calendar 的模块中):

Option Explicit
Option Compare Text

Public PrevVal As Variant, boolDate As Boolean
Sub Basic_Calendar()
    datevariable = CalendarForm.GetDate
    If datevariable <> 0 Then
        PrevVal = Selection.value: boolDate = True 'memorize the previous value
                                                   'and mark the case of Date Picker use
        Selection.value = datevariable
    End If
End Sub

然后使用下一个改编的SelectionChange事件:

Private Sub worksheet_SelectionChange(ByVal Target As Excel.Range)
  If Not Intersect(Target, Range("M3:M100")) Is Nothing Then
        Call Basic_Calendar
  Else
        boolDate = False 'make it false to trigger the previous behavior in Worksheet_Change event
  End If
End Sub

和 Worksheet_Change事件:

Private Sub Worksheet_Change(ByVal Target As Range)   'Log Changes of Current Sheet and put in Sheet("Log")
 Dim RangeValues As Variant, r As Long, boolOne As Boolean, TgValue  'the array to keep Target values (before UnDo)
 Dim SH As Worksheet: Set SH = Sheets("Log")
 Dim UN As String: UN = Application.UserName
 
 If Not Intersect(Target, Range("AK:XFD")) Is Nothing Then Exit Sub  'not doing anything if a cell in AK:XFD is changed
 
 Application.ScreenUpdating = False
 Application.Calculation = xlCalculationManual
 
 If Target.Cells.Count > 1 Then
    TgValue = ExtractData(Target)
 Else
    TgValue = Array(Array(Target.value, Target.Address(0, 0)))  'Put the target range in an array (or as a string for a single cell)
    boolOne = True
 End If
 
 Application.EnableEvents = False            'Avoid trigger the change event after UnDo
     If boolDate Then  '____________________________________________________________
        Dim prevTarget
        prevTarget = Target.value            'memorize the target value
        Target.value = PrevVal               'change the target value to the one before changing
        RangeValues = ExtractData(Target)    'extract data exactly as before
        Target.value = prevTarget            'set the last date
     Else                   '____________________________________________________________
        Application.Undo
        RangeValues = ExtractData(Target)    'Define RangeValue
        PutDataBack TgValue, ActiveSheet     'Put back the changed data
     End If
     
     If boolOne Then Target.Offset(1).Select
 Application.EnableEvents = True

 Dim columnHeader As String, rowHeader As String
 
 For r = 0 To UBound(RangeValues)
    If RangeValues(r)(0) <> TgValue(r)(0) Then
        columnHeader = Cells(1, Range(RangeValues(r)(1)).Column).value
        rowHeader = Range("B" & Range(RangeValues(r)(1)).Row).value
        
        Sheets("Log").Range("A" & Rows.Count).End(xlUp).Offset(1, 0).Resize(1, 6).value = _
            Array(UN, Now, rowHeader, columnHeader, TgValue(r)(0), RangeValues(r)(0))
    End If
 Next r
 
  Application.ScreenUpdating = True
  Application.Calculation = xlCalculationAutomatic          
 End Sub

使用相同的现有功能( ExtractData 和 PutDataBack )并在使用后发送一些反馈...