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 Range
Addr As String
fx As String
RangeEvent As Range
columnFill As Long
time As Single
value As Variant
End Type
Private Work As AutoFillOrderArguments
Function AutoFillOrder(ByVal RangeEvent As Range, ParamArray Params())
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 Not .newXL Then If Not r.Parent Is ActiveSheet Then AutoFillOrder = r.value: Exit Function
If .action = 0 Then
.Addr = s
Set .ThisCell = r
Set .RangeEvent = RangeEvent
.columnFill = r.Column - RangeEvent.Column
.fx = r.Formula
.action = 1
.time = Timer
End If
If .action = 3 Then
AutoFillOrder = .value
Dim w As AutoFillOrderArguments: Work = w
Exit Function
Else
AutoFillOrder = "[Filling]"
End If
End With
FONSetTimer 2
End Function
Private Sub FONSetTimer(id&)
Call SetTimer(Application.hwnd, 1241215 + 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
FillOrderNumbers_working CLng(idEvent - 1241215)
End Sub
Private Sub FillOrderNumbers_working(ByVal direction&)
On Error Resume Next
Static acell As Range
If Timer - Work.time > 1 Then
Set acell = Nothing: Work.action = 0: Exit Sub
End If
Select Case direction
Case 1: SendKeys "^", False: SendKeys "^v", False: FONSetTimer 0: Exit Sub
Case 0
Application.Goto acell, False
Application.ScreenUpdating = True
Application.EnableEvents = True
Application.DisplayAlerts = True
Application.Calculation = xlCalculationAutomatic
Work.action = 0
Dim w As AutoFillOrderArguments
Work = w
Set acell = Nothing
Exit Sub
End Select
Dim r&, r0&, cr&, k&, m&, i&, c&, rg, rg1, rg2, area, n&, n2&, s, o, v
Set acell = ActiveCell
With Work
.action = 2
s = OrderNumbers(.RangeEvent, .columnFill, Not .newXL, v)
If .newXL Then
.action = 3: .value = s: .ThisCell.Dirty
Else
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.DisplayAlerts = False
Application.Calculation = xlCalculationManual
.value = v
If .ThisCell.HasArray Then
.ThisCell.CurrentArray.Clear
.ThisCell.Formula = .fx
Else
.ThisCell.Dirty
End If
Application.Goto .ThisCell(.ThisCell.MergeArea.Rows.Count + 1, 1), False
With oGlb_DataObject
.SetText s
.PutInClipboard
End With
.action = 3
FONSetTimer 1
End If
End With
End Sub
Private Function OrderNumbers(RangeEvent, columnFill, Optional repString As Boolean, Optional value)
On Error Resume Next
value = vbNullString
Dim x&, r&, r0&, cr&, k&, m&, i&, c&, rg, rg1, rg2
Dim area, n&, n2&, s$, o, z, b As Boolean
Set rg = RangeEvent.Resize(, 1)
Set rg2 = rg(1, columnFill + 1)
r0 = rg.Row
Set rg1 = rg.SpecialCells(xlCellTypeConstants)
n2 = r0
ReDim z(1 To 1)
For k = 1 To rg1.Areas.Count
Set area = rg1.Areas(k): cr = area.Row: c = cr - r0
Err.Clear: n = area.value
If Err = 0 Then
If n > 0 Then
If cr > n2 Then
If Not b Then b = True
For i = 1 To area.Row - n2
m = m + 1: ReDim Preserve z(1 To m): z(m) = vbNullString
Next
End If
For i = 1 To n
If i > 1 Then If area(i, 1).value <> Empty Then n = i: Exit For
m = cr + i - r0: ReDim Preserve z(1 To m): z(m) = i
If Not b Then value = 1: b = 2
Next
n2 = cr + n - 1
End If
End If
Next
i = n2: k = 0
If repString Then
Do
i = i + 1: ReDim Preserve z(1 To i): z(i) = vbNullString
If rg(i, columnFill + 1).value = Empty Then
k = k + 1: If k > 200 Then Exit Do
End If
Loop
s = Join(z, vbLf)
s = Mid$(s, InStr(s, vbLf) + 1)
OrderNumbers = s
Else
OrderNumbers = Application.Transpose(z)
End If
End Function
Private Function oGlb_DataObject() 'as MSForms.DataObject
Static o As Object
If o Is Nothing Then Set o = CreateObject("New:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
If o Is Nothing Then Set o = CreateObject("New:{3181A65A-CC39-4CDE-A4DF-2E889E6F1AF1}")
Set oGlb_DataObject = o
End Function
