Option Explicit
#If VBA7 Then
Private Declare PtrSafe Function SetTimer Lib "USER32" (ByVal hwnd As LongPtr, ByVal nIDEvent As LongPtr, ByVal uElapse As LongPtr, ByVal lpTimerFunc As LongPtr) As Long
Private Declare PtrSafe Function KillTimer Lib "USER32" (ByVal hwnd As LongPtr, ByVal nIDEvent As LongPtr) As Long
#Else
Private Declare Function SetTimer Lib "user32" (ByVal HWnd As Long, ByVal nIDEvent As Long, ByVal uElapse As Long, ByVal lpTimerFunc As Long) As Long
Private Declare Function KillTimer Lib "user32" (ByVal HWnd As Long, ByVal nIDEvent As Long) As Long
#End If
'///////////////////////////////////////////////////////
#If Win64 Then
Private gTimerID As LongPtr
#Else
Private gTimerID As Long
#End If
'///////////////////////////////////////////////////////
Private CompareDateAgrs(), CompareDateIndex As Integer
Function S_CompareDate(Compare As Variant, _
ByVal WithCell As Excel.Range, _
Optional ByVal AutoFitRow As Boolean = False) As String
On Error Resume Next
KillTimer 0&, gTimerID: gTimerID = 0
'-----------------------------------------------
S_CompareDate = VBA.Replace(VBA.Mid(Application.Caller.Formula, 2), "S_CompareDate", "S_CompareDate", , , 1)
'-----------------------------------------------
Dim UB As Integer, i As Integer, f As Integer, K As Integer, Fit, Arg
Set WithCell = WithCell.Parent.Range(WithCell.Address)
'-----------------------------------------------
UB = UBound(CompareDateAgrs, 2): K = UB
If K > 0 Then GoSub CheckIn
If f = 0 Then K = K + 1:
ReDim Preserve CompareDateAgrs(1 To 2, 1 To K)
CompareDateAgrs(1, K) = Compare
Set CompareDateAgrs(2, K) = WithCell
CompareDateAgrs(3, K) = AutoFitRow
gTimerID = SetTimer(0&, 0&, 0, AddressOf S_CompareDate_callback)
Exit Function
CheckIn:
i = VBA.IIf(CompareDateIndex > 0 And CompareDateIndex <= K, CompareDateIndex, 1)
For f = i To K
If CompareDateAgrs(2, f).Worksheet Is WithCell.Worksheet Then
If CompareDateAgrs(2, f).Address = WithCell.Address Then Return
End If
Next
f = 0
Return
End Function
'///////////////////////////////////////////////////////
Private Sub S_CompareDate_callback()
On Error Resume Next
Static EarliestTime As Date, Procedure As String
Procedure = "'" & ThisWorkbook.Name & "'!S_CompareDate_callback"
Call KillTimer(0&, gTimerID): gTimerID = 0
Call Application.OnTime(EarliestTime, Procedure, , False)
'----------------------------------
Dim UB As Integer
UB = UBound(CompareDateAgrs, 2)
If UB > 0 Then
CompareDateIndex = CompareDateIndex + 1
Dim a As Variant, b As String, SP() As String, i As Integer
a = CompareDateAgrs(1, CompareDateIndex)
If Not IsDate(a) Or a = "" Then Exit Sub
a = Format(a, "dd/mm/yyyy")
Debug.Print CDate(a)
b = CompareDateAgrs(2, CompareDateIndex).Value
SP = Split(b, Chr(10))
For i = LBound(SP) To UBound(SP)
If IsDate(SP(i)) Then
If CDate(SP(i)) = CDate(a) Then : GoTo N
If CDate(SP(i)) > CDate(a) Then
SP(i) = CStr(a) & Chr(10) & SP(i): GoTo N
End If
End If
Next
SP(UBound(SP)) = SP(UBound(SP)) & Chr(10) & CStr(a)
N: b = Join(SP, Chr(10))
CompareDateAgrs(2, CompareDateIndex).Value = b
If CompareDateAgrs(3, CompareDateIndex) Then
CompareDateAgrs(2, CompareDateIndex).WrapText = True
CompareDateAgrs(2, CompareDateIndex).EntireRow.AutoFit
End If
If CompareDateIndex >= UB Then
Erase CompareDateAgrs: CompareDateIndex = 0
Else
EarliestTime = VBA.Now()
Call Application.OnTime(EarliestTime, Procedure)
End If
End If
End Sub
