Method 'Undo' of object 'Application' failed , How to fix?-CodePudding

I have two codes depend on application events to run.

Code (1) @worksheet_SelectionChange Insert Date by using Date Picker 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

Code (2)@ Worksheet_Change Log changes of any cells of ActiveSheet and put in another sheet("Log").

Error raised : after insert any value by using Date Picker, I got this error

Method 'Undo' of object '_Application' failed

on this line Application.Undo on Code (2).
I tried to add to add If Target.Cells.CountLarge = 1 just below worksheet_SelectionChange event , But the same Problem.

As always: any help will be appreciated. (Link for the real file found in first comment)

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

CodePudding user response：

Please copy the next code instead of existing (in the module containing 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

Then use the next adapted SelectionChange event:

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

and Worksheet_Change event:

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

Use the same existing functions (ExtractData and PutDataBack) and send some feedback after using it...