Excel 抓取每个组在多个工作表上的第一个和最后一个事件

问题描述

我有两张工作表，显示每组（轨道）的打开和关闭值。 所有行都带有日期。 我想在所有工作表中循环，获取最早的column Open值和最近的column Close值。 伪代码：

第一个工作表的每组最早和最新值

在每个工作表中，为每个组获取“打开”的最早值和“关闭”的最新值

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

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

重复步骤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

工作表称为

名为145jki的工作表

预期结果

试试这个代码

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

Sub-Grab\u First\u Last\u occurrence\u Per\u Group\u cross\u worksheet（）
将ws设置为工作表
Dim a（）作为变量
变光温度
Dim prev作为变体
作为布尔函数的Dim f
我想我会坚持多久
变暗p为长
Application.ScreenUpdating=False
对于此工作簿中的每个ws。工作表
与ws
如果.Name“1”和.Name“预期”，则
temp=ws.Range（“A2:D”和ws.Cells（Rows.Count，1）.End（xlUp.Row）.Value
如果f那么
a=阵列连接（a，温度）
其他的
a=温度
f=真
如果结束
如果结束
以
下一个ws
泡泡运动a，2
泡泡运动a，1
重拨b（1到UBound（a，1），1到5）
对于i=1到UBound（a，1）
如果a（i，1）prev那么
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）
如果p>1，则
b（p-1,3）=a（i-1,2）
b（p-1,5）=a（i-1,4）
如果结束
上一个=a（i，1）
如果结束
接下来我
附页（“1”）
.范围（“A1”）.调整大小（1，5）。值=数组（“轨迹”、“开始日期”、“结束日期”、“首次打开”、“最后关闭”）
.Range（“A2”）。调整大小（p，UBound（b，2））。值=b
以
Application.ScreenUpdating=True
端接头
函数数组连接（ByVal a、ByVal b）
我想我会坚持多久
只要
长得一样
ub=UBound（a，1）
a=应用程序转置（a）
重读保存a（1到UBound（a，1），1到ub+UBound（b，1））
a=应用程序转置（a）
对于i=LBound（b，1）到UBound（b，1）
对于ii=1到UBound（b，2）
a（ub+i，ii）=b（i，ii）
下一个ii
接下来我
ArrayJoin=a
端函数
函数BubbleSort（arr（）作为变量，sortIndex作为长）
作为布尔值的dimb
我想我会坚持多久
Dim j尽可能长
ReDim v（LBound（arr，2）到UBound（arr，2））作为变体
做
b=正确
对于i=LBound（arr）到UBound（arr）-1
如果arr（i，sortIndex）>arr（i+1，sortIndex），那么
b=错误
对于j=LBound（v）至UBound（v）
v（j）=arr（i，j）
arr（i，j）=arr（i+1，j）
arr（i+1，j）=v（j）
下一个
如果结束
接下来我
循环而不是b
端函数

如何将数据合并到一个数组中，然后将结果放入新的工作表中。。然后用你的代码处理新工作表中的新数据？这就是我的结论，创建了一个新工作表。虽然我没有使用数组，但我在VBA方面没有太多经验，所以我现在想让它简单明了。

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

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

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