Option Explicit
#If VBA7 = 0 Then
Private Enum LongPtr:[_]:End Enum
#End If
#If -VBA7 And -Win64 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 LongPtr
Private Declare PtrSafe Function KillTimer Lib "user32" (ByVal hwnd As LongPtr, ByVal nIDEvent As LongPtr) As LongPtr
#ElseIf 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
Private Type AutoFillOrderArguments
newxl As Boolean
action As Long
direction As Long
ThisCell As Object
Addr As String
fx As String
FirstSeries As Range
LastSeries As Range
time As Single
value As Variant
End Type
Private Work As AutoFillOrderArguments
Function FillSeries(ByVal FirstSeries As Range, ByVal LastSeries As Range)
On Error Resume Next
Dim r As Object, s$, k%, i%, p, j%
Set r = Application.Caller
If Err Then Exit Function
With Work
Err.Clear: s = r.Formula2: .newxl = Err = 0
If .newxl Then FillSeries = OrderNumbers(FirstSeries, LastSeries, , .newxl): Exit Function
If Not .newxl Then If Not r.Parent Is ActiveSheet Then FillSeries = r.value: Exit Function
If .action = 0 Then
.Addr = s
Set .ThisCell = r
Set .FirstSeries = FirstSeries
Set .LastSeries = LastSeries
.fx = r.Formula
.action = 1
.time = Timer
FONSetTimer 2
End If
If .action = 3 Then
FillSeries = .value
Dim w As AutoFillOrderArguments: Work = w
Exit Function
Else
FillSeries = "[FillSeries]"
End If
End With
End Function
Private Sub FONSetTimer(id&)
Call SetTimer(Application.hwnd, 1221215 + id, 100, AddressOf FillOrderNumbers_callback)
End Sub
Private Sub FillOrderNumbers_callback(ByVal hwnd As LongPtr, ByVal wMsg As LongPtr, ByVal idEvent As LongPtr, ByVal dwTime As LongPtr)
On Error Resume Next
KillTimer hwnd, idEvent
Dim r&, r0&, cr&, k&, m&, i&, c&, rg, rg1, rg2, area, n&, n2&, s, o, v
With Work
.action = 2
s = OrderNumbers(.FirstSeries, .LastSeries, v, .newxl)
If .newxl Then
.action = 3: .value = s: .ThisCell.Dirty
Else
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.DisplayAlerts = False
Application.Calculation = xlCalculationManual
.value = v
.ThisCell.Resize(UBound(s), UBound(s, 2)).value = s
If .ThisCell.HasArray Then
.ThisCell.CurrentArray.Clear
End If
If .newxl Then .ThisCell.Formula2 = .fx Else .ThisCell.Formula = .fx
.action = 3
Application.ScreenUpdating = True
Application.EnableEvents = True
Application.DisplayAlerts = True
Application.Calculation = xlCalculationAutomatic
End If
End With
End Sub
Private Function OrderNumbers(FirstSeries As Range, LastSeries As Range, Optional value, Optional newxl As Boolean)
value = vbNullString
Dim x&, r&, k&, m&, i&, c&, v1$, v2$, f$
Dim area, n2&, s$, z, iz()
c = FirstSeries.Rows.Count
ReDim iz(1 To c, 4)
For k = 1 To c
s = FirstSeries(k, 1).value: v1 = "": v2 = "": iz(k, 0) = s: iz(k, 1) = 0: iz(k, 2) = 0: iz(k, 3) = 0: iz(k, 4) = 0
For i = 1 To Len(s)
If IsNumeric(Mid$(s, i)) Then iz(k, 1) = CLng(Mid$(s, i)): v1 = Left(s, i - 1): iz(k, 3) = i: iz(k, 4) = Len(s) - i + 1: Exit For
Next
s = LastSeries(k, 1).value
For i = 1 To Len(s)
If IsNumeric(Mid$(s, i)) Then x = CLng(Mid$(s, i)): iz(k, 2) = x: m = IIf((x - iz(k, 1) + 1) > m, (x - iz(k, 1) + 1), m): v2 = Left(s, i - 1): Exit For
Next
If v1 <> v2 Or v1 = "" Then iz(k, 0) = ""
Next
ReDim z(1 To m + 1000 * (1 + newxl), 1 To c) As String
value = iz(1, 0)
For i = 1 To c
s = iz(i, 0)
If s <> Empty Then
f = String(iz(i, 4), "0"): k = 0
For r = iz(i, 1) To iz(i, 2): k = k + 1
Mid$(s, iz(i, 3), iz(i, 4)) = Format(r, f): z(k, i) = s
Next
End If
Next
OrderNumbers = z
End Function
