Sub mrshkei()
Dim PP As String, i As Long, k As Long, lr As Long, sh As Worksheet
Set sh = Worksheets("Лист1")
PP = "ПЛАТЕЖНОЕ ПОРУЧЕНИЕ №"
k = 3
With Worksheets("Лист2")
    lr = .Cells(Rows.Count, 1).End(xlUp).Row
    For i = 1 To lr
        If .Cells(i, 1) = PP Then
            sh.Cells(k, 1) = .Cells(i, 9)
            sh.Cells(k, 2) = .Cells(i, 10)
            sh.Cells(k, 3) = k - 2
            sh.Cells(k, 4) = .Cells(i + 33, 1)
            sh.Cells(k, 5) = .Cells(i + 4, 21)
            sh.Cells(k, 6) = .Cells(i + 23, 1)
            k = k + 1
        End If
    Next i
End With
End Sub

Sub getAndParseData()
Path = ThisWorkbook.Path & Application.PathSeparator & "откуда.rtf"
Set wd = CreateObject("Word.Application")
wd.documents.Open Path
wd.Visible = True
n = 6
For i = 1 To wd.activedocument.Paragraphs.Count
DoEvents
If InStr(1, wd.activedocument.Paragraphs(i).Range.Text, "ПЛАТЕЖНОЕ ПОРУЧЕНИЕ") > 0 Then
n = n + 1
Cells(n, 1).Value = Application.Clean(wd.activedocument.Paragraphs(i + 1).Range.Text)
Cells(n, 2).Value = Application.Clean(wd.activedocument.Paragraphs(i + 2).Range.Text)
Cells(n, 3).Value = Application.Clean(Application.WorksheetFunction.Round(i / 187, 0) + 1)
Cells(n, 5).Value = Application.Clean(wd.activedocument.Paragraphs(i + 30).Range.Text)
Cells(n, 6).Value = Application.Clean(wd.activedocument.Paragraphs(i + 120).Range.Text)
Cells(n, 4).Value = Application.Clean(wd.activedocument.Paragraphs(i + 155).Range.Text)
End If
Next i
wd.documents.Close
wd.Quit
Set wd = Nothing
End Sub