Sub vf()
Dim arr, brr()
arr = [a1].CurrentRegion
ReDim brr(2 To UBound(arr), 1 To 2)
k = 1
For i = 3 To UBound(arr) - 1
If arr(i, 1) = [d2] And arr(i + 1, 1) = [d3] Then
k = k + 1
brr(k, 1) = arr(i - 1, 1)
brr(k, 2) = arr(i + 2, 1)
End If
Next
[l2].Resize(k, 2) = brr
End Sub