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

Private Sub CommandButton1_Click()
Dim doc As Object
Dim fdOpen As FileDialog
Dim mPath As String
Dim sDoc As String
Dim sTmp As String

Dim xlApp As Object, wkS As Object
Dim k As Long


mPath = ThisDocument.Path

'выбрать текстовый файл для обработки
Set fdOpen = Application.FileDialog(msoFileDialogOpen)
With fdOpen
    .AllowMultiSelect = False
    .InitialFileName = mPath & "\"
    .Filters.Add "Text File", "*.txt",  1 
    .Title = "Выбор документа для обработки"
    If .Show = - 1  Then sDoc = .SelectedItems( 1 )
End With
Set fdOpen = Nothing

If sDoc <> "" Then
    
On Error GoTo Err
    
    'открыть текстовый файл для чтения
    Set doc = CreateObject("Scripting.FileSystemObject").OpentextFile(sDoc,  1 )
    
    'открыть Excel, создать новую книгу, дать ссылку на первый лист
    Set xlApp = CreateObject("Excel.Application")
    Set wkS = xlApp.workbooks.Add.worksheets( 1 )
    
    k =  1 
    'цикл по всем строкам текстового файла
    Do Until doc.AtEndOfStream
        sTmp = doc.ReadLine
        If sTmp = "№" Then
            'если нет уверенности, что в последнем документе есть что-то после строки "№"
            'If doc.AtEndOfStream Then Exit Do Else wkS.Cells(k, 1) = doc.ReadLine
            
            'если уверен, что в последнем документе есть что-то после строки "№"
            wkS.Cells(k,  1 ) = doc.ReadLine
        ElseIf sTmp = "Оплата" Then
            With wkS
                'если нет уверенности, что в последнем документе есть все поля в строке "оплата"
                'If doc.AtEndOfStream Then Exit Do Else .Cells(k, 6) = doc.ReadLine
                'If doc.AtEndOfStream Then Exit Do Else .Cells(k, 5) = doc.ReadLine
                'If doc.AtEndOfStream Then Exit Do Else .Cells(k, 4) = doc.ReadLine
                'If doc.AtEndOfStream Then Exit Do Else .Cells(k, 3) = doc.ReadLine
                'If doc.AtEndOfStream Then Exit Do Else .Cells(k, 2) = doc.ReadLine
                
                'если уверен, что в последнем документе есть все поля в строке "оплата"
                .Cells(k,  6 ) = doc.ReadLine
                .Cells(k,  5 ) = doc.ReadLine
                .Cells(k,  4 ) = doc.ReadLine
                .Cells(k,  3 ) = doc.ReadLine
                .Cells(k,  2 ) = doc.ReadLine
            End With
            k = k +  1 
        End If
    Loop
    
Err:
    If Err.Number <>  0  Then
        MsgBox Err.Number & vbCrLf & Err.Description, vbExclamation, "dung happens"
        Err.Clear
    End If
    If Not (xlApp Is Nothing) Then
        Set wkS = Nothing
        xlApp.Visible = True
        Set xlApp = Nothing
    End If
    
    If Not (doc Is Nothing) Then
        doc.Close
        Set doc = Nothing
    End If
End If
End Sub