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 Args(), WorkIndex As Integer
Function S_Scraper(ByVal target As Range) As Variant
On Error Resume Next
Dim k As Integer, i%, R, t$
Set R = Application.Caller
S_Scraper = scraper(target(1, 1).Value)(0)
t = R.Formula
k = UBound(Args)
If k > 0 Then
For i = 1 To k
If Args(i)(3) = t And Args(i)(1) = 0 Then
Exit Function
End If
Next
End If
ReDim Preserve Args(1 To k + 1)
Args(k + 1) = VBA.Array(R, 0, target, t)
If gTimerID = 0 Then gTimerID = SetTimer(0&, 0&, 1, AddressOf S_Scraper_callback)
End Function
Private Sub S_Scraper_callback()
On Error Resume Next
Call KillTimer(0&, gTimerID): gTimerID = 0
S_Scraper_callback2
On Error GoTo 0
End Sub
Private Sub S_Scraper_callback2()
On Error Resume Next
Dim UA%, s$, a
UA = UBound(Args)
If UA > 0 Then
WorkIndex = WorkIndex + 1
a = Args(WorkIndex)
If a(1) = 0 And a(0).Formula = a(3) Then
Dim R&, R1, C%, LR&, LR2&, Arr, total$(), total2$(), cols%, ub2%, t, re As Object
LR = a(2)(a(2).Rows.Count + 2, 1).End(3).Row - a(2).Row + 1
If LR > 0 Then
Set R1 = a(0).Parent.UsedRange
LR2 = R1.Row + R1.Rows.Count - 1 - a(0)(1, 1).Row
If LR2 < LR Then LR2 = LR
Arr = a(2)(1, 1).Resize(LR, 1).Value
t = scraper(Arr(1, 1), re)
ub2 = UBound(t)
If ub2 > 0 Then
ReDim total2(1 To ub2)
For C = 1 To ub2
total2(C) = t(C)
Next
a(0)(1, 2).Resize(1, ub2).Value = total2
End If
For R = 2 To LR
t = scraper(Arr(R, 1), re)
ub2 = UBound(t) + 1
If ub2 > cols Then
cols = ub2
ReDim Preserve total(1 To LR2, 1 To cols)
End If
For C = 1 To ub2
total(R - 1, C) = t(C - 1)
Next
Next
a(0)(2, 1).Resize(LR2, cols).Value = total
End If
a(1) = 1
End If
If WorkIndex >= UA Then
Erase Args: WorkIndex = 0: Set re = Nothing
Else
gTimerID = SetTimer(0&, 0&, 1, AddressOf S_Scraper_callback): Exit Sub
End If
End If
On Error GoTo 0
End Sub
Private Function scraper(ByVal text$, Optional ByRef re As Object)
scraper = Array("")
If re Is Nothing Then
Set re = VBA.CreateObject("VBScript.RegExp")
With re
.Global = True
.IgnoreCase = True
.MultiLine = True
.pattern = "([\n':-] +(\d{4,30}))|((\d{4,30}) ?[,_-])"
End With
End If
Dim m, ms, t$, i%, k%, Arr()
Set ms = re.Execute(text)
If ms.Count Then
ReDim Arr(ms.Count - 1)
For i = 0 To ms.Count - 1
For k = 0 To 1
t = ms(i).submatches(k * 2 + 1)
If t <> vbNullString Then
Arr(i) = t
Exit For
End If
Next
Next
scraper = Arr
End If
End Function
