I am using below codes as the following:
Code(1)@ Worksheet_SelectionChange Insert Date by using Date Picker(calendar) on sheet "North"
Column M.
Code(2) @ Worksheet_Change of sheet North to Log changes of any cells and put in sheet("Log").
Code(3) in a separate module "Calendar" to initiate calendar
the codes works except in one condition
Target cells not triggered by event Worksheet_Change
to produce issue use calendar to enter any value but not click outside Column M then delete these values again , then switch to sheet "Log" you will notice that there are no entries for deleted values at all.
As always: any help will be appreciated.
(Link for the real file found in first comment)
Option Explicit
Option Compare Text
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
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
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
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
' in a separate module "Calendar" to initiate calendar Option Explicit Option Compare Text
Public PrevVal As Variant, boolDate As Boolean
Sub Basic_Calendar()
Dim datevariable As Variant
datevariable = CalendarForm.GetDate
If datevariable <> 0 Then
PrevVal = Selection.value: boolDate = True
Selection.value = datevariable
End If
End Sub
CodePudding user response:
In order to make the solution allowing multiple cells entry from the Callendar, but also allowing multiple deletions, please adapt it in the next way:
- Use this modified code in the module where
Basic_CalendarSubexists:
Option Explicit
Option Compare Text
Public PrevVal(), boolDate As Boolean
Sub Basic_Calendar()
Dim datevariable As Variant
datevariable = CalendarForm.GetDate
If datevariable <> 0 Then
PrevVal = Selection.value: boolDate = True
Selection.value = datevariable
Else
Erase PrevVal 'to identify the case of deletion
End If
End Sub
- Adapt this part of the
Worksheet_Changeevent code in the next way:
If Target.Cells.Count > 1 Then
If Not CBool(Not Not PrevVal) Then boolDate = False 'the new line checking if the multiple rows array is empty (or not)
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
The logic of the modification works as following:
a. When the Calendar form is called and it returns a Date, in a multi rows range, the delivered datevariable is dropped in the selected cells, and their previous value are loaded in PrevVal() array;
b. A change in Column "M:M" triggers the event and in case of PrevVal() not empty, it acts as usually for inserting Data (using the PrevVal() array elements instead of UnDo, which does not work for data added by code). In case of an empty array, it makes boolDate = False, switching the code to the clasic variant (able to use UnDo, because deletion has been done by the user)...
No need to check the code on another PC. It was a matter of solution logic starting from a wrong assumption and it cannot work differently than on your laptop.
