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