так?
[vba]Код
Sub обработка()
Dim i As Long, k As Long, arr(), str
Application.ScreenUpdating = False
For i = Range("I" & Rows.Count).End(xlUp).Row To 1 Step -1
If Range("I" & i) = "пикет" And Range("I" & i + 1) = "ориентир" Then
Rows(1 + i).Resize(2).EntireRow.Insert
str = ""
For k = i To 2 Step -1
If Range("I" & k) = "станция" And Range("I" & k - 1) = "ориентир" Then
str = k - 1 & ":" & k
arr() = ActiveSheet.Range(str).Value
Exit For
End If
Next k
If str <> "" Then
str = i + 1 & ":" & i + 2
ActiveSheet.Range(str).Value = arr()
End If
End If
Next i
Application.ScreenUpdating = True
End Sub
[/vba]