在多个工作表中获取每组的第一次和最后一次出现

Question

问题描述

我有几个工作表显示每个组（轨道）的打开和关闭值。 所有行都带有日期。 我想遍历所有工作表并获取 Open 列的最旧值和 Close 列的最新值。 伪代码：

1. 第一个工作表每组的最旧和最新值

每个工作表，获取 Open 的最旧值和 Close 每个组的最新值

1. 转到下一个工作表并比较值

接下来，转到下一个工作表并将最旧的值和新值与之前捕获的值进行比较。对于每个组，如果当前工作表中的日期较旧，则用当前工作表中的相应值覆盖最旧的值。 如果当前工作表中的日期较新，则用相应的值覆盖最近的值。

1. 重复第 2 步，直到我们遍历所有工作表。

我已经能够捕获每个工作表中最早和最新的值。 但是，我不知道如何遍历所有工作表并在所有工作表中获取每组中最旧和最新的值。

我是 Excel VBA 的初学者，我想按照我当前的代码坚持使用简单的循环。我想“按原样”循环工作表，这意味着在运行任何代码之前不重命名也不合并到一个工作表中（总共可能超过一百万行）。

获取每个工作表值的当前代码：

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

屏幕转储

工作表数据

名为 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

工作表称为一个

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

名为 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

预期结果

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

试试这个代码

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