Sub ExpToXL()
Dim xlApp As Object, wkS As Object
Dim i As Long, k As Long

'открыть Excel, создать новую книгу, дать ссылку на первый лист
Set xlApp = CreateObject("Excel.Application")
Set wkS = xlApp.workbooks.Add.worksheets( 1 )

i =  1 
k =  1 
On Error GoTo Err
'цикл по всем _абзацам_ (и кто так строит!?) документа
Do Until i > Paragraphs.Count
If Left$(Paragraphs(i).Range.Text,  1 ) = "№" Then
    'нашли "строку" с номером, проверили, есть ли сам номер
    If i +  1  > Paragraphs.Count Then Exit Do
    'записали значение номера в Excel
    'rem убираем переводы строк
    wkS.Cells(k,  1 ) = Trim$(Replace(Paragraphs(i +  1 ).Range.Text, vbCr, ""))
    i = i +  1 
ElseIf Left$(Paragraphs(i).Range.Text,  6 ) = "Оплата" Then
    'нашли "строку" с цЫфрами, проверили, есть ли все поля
    If i +  5  > Paragraphs.Count Then Exit Do
    With wkS
        'записали значения цЫфр в Excel
        'NB! порядок абзацев в "строке" цЫфр отличается отвизуального
        '     в Excel выгружаем так, чтобы порядок соответствовал визуальному
        '     убираем переводы строк, разделители разрядов и концевые пробелы
        .Cells(k,  2 ) = Trim$(Replace(Replace(Paragraphs(i +  5 ).Range.Text, vbCr, ""), Chr( 160 ), ""))
        .Cells(k,  3 ) = Trim$(Replace(Replace(Paragraphs(i +  4 ).Range.Text, vbCr, ""), Chr( 160 ), ""))
        .Cells(k,  4 ) = Trim$(Replace(Replace(Paragraphs(i +  3 ).Range.Text, vbCr, ""), Chr( 160 ), ""))
        .Cells(k,  5 ) = Trim$(Replace(Replace(Paragraphs(i +  2 ).Range.Text, vbCr, ""), Chr( 160 ), ""))
        .Cells(k,  6 ) = Trim$(Replace(Replace(Paragraphs(i +  1 ).Range.Text, vbCr, ""), Chr( 160 ), ""))
    End With
    i = i +  5 
    k = k +  1 
End If
i = i +  1 
Loop

Err:
If Err.Number <>  0  Then
    MsgBox Err.Number & vbCrLf & Err.Description, vbExclamation, "dung happens"
    Err.Clear
End If
Set wkS = Nothing
xlApp.Visible = True
Set xlApp = Nothing
End Sub