can some one look at this please

[joi2]

I attached a small word file I am trying to find a way to modify this code so that is picks up only the words that come aftert application and stops picking up words when it gets to the of the cell in that particular table I have written two codes that may be able to do that but I cant seem to get them to do this particular task. here is the first code.

Sub Date_in()
 
    Dim r As Range
    Dim rword As Range
    Dim h As Long, l As Long
    Dim xlApp As Excel.application
    Dim xlWB As Excel.Workbook
    
    
    
    
    'find the marker
    
    Set r = ActiveDocument.Range
   
    
    With r.Find
        .ClearFormatting
        .Text = "Application:"
        .MatchCase = True
        .Forward = True
        
        
        h = 2
        '
        Set xlApp = CreateObject("Excel.Application")
                 xlApp.Visible = True
                 Set xlWB = xlApp.Workbooks.Open("C:\Foldername\Day1.xls")
        Do While .Execute
            Set rword = ActiveDocument.Range
            rword.start = r.End + 1
            Debug.Print rword.Words(1)  
                h = h + 1
                With xlWB.Worksheets(1)
                    .Cells(h, 4).Formula = rword.Words(1) & rword.Words(2) & rword.Words(3) & rword.Words(4) & rword.Words(5)
                End With
                
        Loop
    End With
End Sub

Here is the second one

Sub application()
    Dim r As Range
    Dim rword As Range
    Dim h As Long, l As Long
    Dim xlApp As Excel.application
    Dim xlWB As Excel.Workbook
    
'With ActiveDocument
    Dim seastring1 As String
    Let seastring1 = ThisDocument.Content
    
    Const seastring2 As String = "  "
    Const pook As String = "Application"
    Set xlApp = CreateObject("Excel.Application")
    xlApp.Visible = True
    Set xlWB = xlApp.Workbooks.Open("C:\Foldername\Day1.xls")
    
 
 
 
Dim j As Long
Dim i As Long
h = 2
j = InStr(1, seastring1, seastring2)
i = InStr(1, seastring1, pook)
Do While i <> 0
 
 
 
h = h + 1
                With xlWB.Worksheets(1)
                    .Cells(h, 9).Formula = Mid$(seastring1, i, j - i) ' & " | " & Len(Mid$(seastring1, i, j - i))
                End With
 
'MsgBox Mid$(seastring1, i, j - i), Len(Mid$(seastring1, i, j - i))
'MsgBox pook & i
'MsgBox Mid$(seastring1, i, InStr(seastring1, seastring2) - i) ', Len(Mid$(seastring1, i, InStr(seastring1, seastring2) - i ))
i = InStr(i + 1, seastring1, pook)
j = InStr(j + 1, seastring1, seastring2)
Loop
'End With
End Sub

and attached is the word doc. I working from