问题描述
我有几个工作表显示每组（轨道）的开放和关闭值。 所有行都带有日期。 我想遍历所有工作表并获取列Open的最旧值和列Close的最新值。 伪代码：
根据工作表，获取Open的最旧值和每组关闭的最新值
接下来，转到下一个工作表，并将最旧值和新值与先前捕获的值进行比较。如果当前工作表中的日期较旧，则每组使用当前工作表中的相应值覆盖最旧的值。 如果当前工作表中的日期更新，则使用相应的值覆盖最近的值。
我已经能够捕获每个工作表中最旧和最新的值。 但是，我无法弄清楚如何遍历所有工作表并在所有工作表中获取每组最旧和最新的值。
我是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
Screendumps
工作表数据
名为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
答案 0 :(得分：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