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_Calendar
Sub
exists:
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_Change
event 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.