Grab first and last occurence per group over multiple worksheets - excel

Question

Problem description
I have a couple of worksheets showing open and close values per group (track).
All rows come with a date.
I want to loop through all worksheet and grab the oldest value for column Open and the most recent value for column Close.
Pseudo code:
Oldest and newest value per group for first worksheet
Per worksheet, grab the oldest value for Open and the most recent value for Close per group
Go to next worksheet and compare values
Next, go to the next worksheet and compare the oldest and new values with the previously captured ones. Per group, override the oldest value with the corresponding value in the current worksheet if the date in the current worksheet is older.
Override the most recent value with the corresponding value if the date in the current worksheet is more recent.
Repeat step 2 until we've looped through all worksheets.
I've been able to capture the oldest and most recent values per worksheet.
However, I can't figure out how to loop through all the worksheets and grab the oldest and most recent values per group over all worksheets.
I'm a starter on Excel VBA and want to stick with simple loops as per my current code. I want to loop through the worksheets "as is" meaning no renaming and no merging into one worksheet before running any code (there could be over a million rows in total).
Current code to grab the values per worksheet:
Sub top_one()
Dim WS As Worksheet
Dim group_start As Double
Dim track As String
Dim start_date, end_date As Long
Dim opening, closing As Double
For Each WS In ThisWorkbook.Worksheets
If WS.Name <> "1" And WS.Name <> "Expected" Then
WS.Select
With WS
LastRow = Cells(.Rows.Count, "A").End(xlUp).Row
For i = 2 To LastRow
group_start = 2
If .Cells(i + 1, "A").Value <> .Cells(i, "A").Value Then
group_start = i - group_counter
track = .Cells(i, "A")
start_date = .Cells(group_start, "B")
opening = .Cells(group_start, "C")
end_date = .Cells(i, "B")
closing = .Cells(i, "D")
'lastRowTotal = Sheets("1").Cells(.Rows.Count, "P").End(xlUp).Row
Sheets("1").Cells(j + 2, "A") = .Cells(i, "A") 'trck
'If opening_date < Sheets("1").Cells(j + 2, "B") Then
Sheets("1").Cells(j + 2, "B") = opening_date
'Else
'End If
Sheets("1").Cells(j + 2, "B") = .Cells(group_start, "B") 'start date
Sheets("1").Cells(j + 2, "C") = .Cells(i, "B") 'end date
Sheets("1").Cells(j + 2, "D") = .Cells(group_start, "C") 'opening
Sheets("1").Cells(j + 2, "E") = .Cells(i, "D") 'closing
j = j + 1
group_counter = 0
Else
group_counter = group_counter + 1
End If
Next
j = 0
End With
End If
Next WS
End Sub
Screendumps
Worksheets data
Worksheet called 2018
Track Date Open Close
A 20180101 1 5
A 20180102 4 8
A 20180103 4 5
B 20180104 12 1
B 20180105 2 4
C 20180106 5 2
C 20180107 2 5
E 20180108 8 9
Worksheet called a
Track Date Open Close
A 20170101 5 6
A 20170102 6 6
B 20170103 2 1
B 20170104 1 2
C 20170105 5 9
C 20170106 9 7
D 20170107 5 5
D 20170108 5 8
D 20170109 7 2
Worksheet called 145jki
Track Date Open Close
A 20160101 8 5
A 20160102 4 5
B 20160103 11 5
B 20160104 8 9
C 20160105 10 3
C 20160106 5 7
Expected result
Track Start date End date First Open Last Close
A 20160101 20180103 8 5
B 20160103 20180105 11 4
C 20160105 20180107 10 5
D 20170107 20170109 5 2
E 20180108 20180108 8 9

Answer 1

Try this code
Sub Grab_First_Last_Occurence_Per_Group_Across_Worksheets()
Dim ws As Worksheet
Dim a() As Variant
Dim temp As Variant
Dim prev As Variant
Dim f As Boolean
Dim i As Long
Dim p As Long
Application.ScreenUpdating = False
For Each ws In ThisWorkbook.Worksheets
With ws
If .Name <> "1" And .Name <> "Expected" Then
temp = ws.Range("A2:D" & ws.Cells(Rows.Count, 1).End(xlUp).Row).Value
If f Then
a = ArrayJoin(a, temp)
Else
a = temp
f = True
End If
End If
End With
Next ws
BubbleSort a, 2
BubbleSort a, 1
ReDim b(1 To UBound(a, 1), 1 To 5)
For i = 1 To UBound(a, 1)
If a(i, 1) <> prev Then
p = p + 1
b(p, 1) = a(i, 1)
b(p, 2) = a(i, 2)
b(p, 3) = a(i, 2)
b(p, 4) = a(i, 3)
b(p, 5) = a(i, 4)
If p > 1 Then
b(p - 1, 3) = a(i - 1, 2)
b(p - 1, 5) = a(i - 1, 4)
End If
prev = a(i, 1)
End If
Next i
With Sheets("1")
.Range("A1").Resize(1, 5).Value = Array("Track", "Start Date", "End Date", "First Open", "Last Close")
.Range("A2").Resize(p, UBound(b, 2)).Value = b
End With
Application.ScreenUpdating = True
End Sub
Function ArrayJoin(ByVal a, ByVal b)
Dim i As Long
Dim ii As Long
Dim ub As Long
ub = UBound(a, 1)
a = Application.Transpose(a)
ReDim Preserve a(1 To UBound(a, 1), 1 To ub + UBound(b, 1))
a = Application.Transpose(a)
For i = LBound(b, 1) To UBound(b, 1)
For ii = 1 To UBound(b, 2)
a(ub + i, ii) = b(i, ii)
Next ii
Next i
ArrayJoin = a
End Function
Function BubbleSort(arr() As Variant, sortIndex As Long)
Dim b As Boolean
Dim i As Long
Dim j As Long
ReDim v(LBound(arr, 2) To UBound(arr, 2)) As Variant
Do
b = True
For i = LBound(arr) To UBound(arr) - 1
If arr(i, sortIndex) > arr(i + 1, sortIndex) Then
b = False
For j = LBound(v) To UBound(v)
v(j) = arr(i, j)
arr(i, j) = arr(i + 1, j)
arr(i + 1, j) = v(j)
Next
End If
Next i
Loop While Not b
End Function