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, gTimerID2 As LongPtr
#Else
Private gTimerID As Long, gTimerID2 As Long
#End If
'///////////////////////////////////////////////////////
Private NumberAlternate_OArgs(), NumberAlternate_OIndex As Integer
Function S_NumberAlternate(ByVal values As Range) As Variant
On Error Resume Next
KillTimer 0&, gTimerID: gTimerID = 0
'-----------------------------------------------
Dim Arg As Variant
Arg = values.value
S_NumberAlternate = NumberAlternate(Arg(1, 1))
'-----------------------------------------------
If values.Cells.Count > 1 Then
Dim UB As Integer, K As Integer
'-----------------------------------------------
UB = UBound(NumberAlternate_OArgs, 2): K = UB
K = K + 1
ReDim Preserve NumberAlternate_OArgs(1 To K)
NumberAlternate_OArgs(K) = Array(Arg, Application.Caller)
gTimerID = SetTimer(0&, 0&, 1, AddressOf S_NumberAlternate_callback)
End If
End Function
'///////////////////////////////////////////////////////
Private Sub S_NumberAlternate_callback()
On Error Resume Next
Call KillTimer(0&, gTimerID): gTimerID = 0
Call KillTimer(0&, gTimerID2): gTimerID2 = 0
On Error GoTo 0
'----------------------------------
Dim UA As Integer
UA = UBound(NumberAlternate_OArgs)
If UA > 0 Then
NumberAlternate_OIndex = NumberAlternate_OIndex + 1
'-------------------------------------------
Dim Args, R As Long, C As Integer, total(), total2(), UB As Long, UB2 As Integer
Args = NumberAlternate_OArgs(NumberAlternate_OIndex)
UB = UBound(Args(0)): UB2 = UBound(Args(0), 2)
ReDim total(2 To UB, 1 To UB2)
For R = 2 To UB
For C = 1 To UB2
If Args(0)(R, C) <> "" Then
total(R, C) = NumberAlternate(Args(0)(R, C))
End If
Next
Next
Args(1)(2, 1).Resize(UBound(total) - 1, UB2).value = total
If UB2 > 1 Then
ReDim total2(1 To 1, 2 To UB2)
For C = 2 To UB2
If Args(0)(1, C) <> "" Then
total2(1, C) = NumberAlternate(Args(0)(1, C))
End If
Next
Args(1)(1, 2).Resize(, UB2 - 1).value = total2
End If
'-------------------------------------------
If NumberAlternate_OIndex >= UA Then
Erase NumberAlternate_OArgs: NumberAlternate_OIndex = 0
Else
gTimerID = SetTimer(0&, 0&, 1, AddressOf S_NumberAlternate_callback2)
End If
End If
End Sub
Private Sub S_NumberAlternate_callback2()
S_NumberAlternate_callback
End Sub
Private Function NumberAlternate(ByVal value As String) As Variant
Dim l As Long, s As String, t As String
l = Len(value): t = Right(value, 1)
Do Until l <= 1
l = l - 1: s = Mid(value, l)
If Not s Like t & "*" Then Exit Do
t = s
Loop
NumberAlternate = t
End Function
