Option Explicit
Sub test()
Dim arr, i, j, m, t, p1, p2, a, b, tm(1), dic
Set dic = CreateObject("scripting.dictionary")
arr = [h7].CurrentRegion
For i = 2 To UBound(arr, 1)
If arr(i, 2) < arr(i, 3) Then t = arr(i, 2): arr(i, 2) = arr(i, 3): arr(i, 3) = t
dic(arr(i, 1)) = Array(arr(i, 2), arr(i, 3))
Next
arr = [p7].CurrentRegion
ReDim brr(1 To 2 * UBound(arr, 2), 1 To 5)
tm(0) = [p8].Value '开始时间,指定单元格
tm(1) = Cells([p8].End(xlDown).Row, "p").Value '结束时间,指定单元格
For j = 2 To UBound(arr, 2)
If dic.exists(arr(1, j)) Then
p1 = 0: p2 = 0
For i = 2 To UBound(arr, 1)
If arr(i, 1) >= tm(0) And arr(i, 1) <= tm(1) Then
If arr(i, j) > dic(arr(1, j))(0) Then
If p1 > 0 Then
If arr(i, j) > a Then p1 = i: a = arr(i, j)
Else
p1 = i: a = arr(i, j)
End If
End If
If arr(i, j) < dic(arr(1, j))(1) Then
If p2 > 0 Then
If arr(i, j) < b Then p2 = i: b = arr(i, j)
Else
p2 = i: b = arr(i, j)
End If
End If
End If
Next
If p1 > 0 Then
m = m + 1
brr(m, 1) = arr(1, j): brr(m, 2) = arr(p1, 1)
brr(m, 3) = arr(p1, j): brr(m, 4) = dic(arr(1, j))(0)
End If
If p2 > 0 Then
m = m + 1
brr(m, 1) = arr(1, j): brr(m, 2) = arr(p2, 1)
brr(m, 3) = arr(p2, j): brr(m, 5) = dic(arr(1, j))(1)
End If
Else
MsgBox arr(1, j)
End If
Next
[b22].Resize(UBound(brr, 1), UBound(brr, 2)) = brr
End Sub |