=ИНДЕКС(ДО!B:B;ПОИСКПОЗ(B4;ДО!B:B;)+1;)

Sub Do_Posle()
Application.ScreenUpdating = False
Dim arrDo(), arrPosle()
Dim I&, N&
On Error Resume Next
With Worksheets("ДО")
    arrDo = .Range("B4:C" & .Cells(.Rows.Count, 3).End(xlUp).Row).Value
End With
For I = 1 To UBound(arrDo) Step 2
    ReDim Preserve arrPosle(2, N)
    arrPosle(0, N) = arrDo(I, 1)
    arrPosle(1, N) = arrDo(I + 1, 1)
    arrPosle(2, N) = arrDo(I + 1, 2)
    N = N + 1
Next
With Worksheets("ПОСЛЕ")
    .Range("B4").Resize(UBound(arrPosle, 2) + 1, 3) = Application.Transpose(arrPosle)
    With .Columns("B:D")
        .EntireColumn.AutoFit
        .NumberFormat = "000000000"
    End With
End With
Application.ScreenUpdating = True
End Sub