can some one look at this please

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.

VB 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

VB Code:

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

Hi,

The following code might work for you if you receive the same setup (same type of document and in table format).

VB Code:

Sub Find_Text()
Dim FinalText As String
Dim I As Integer
Dim xlApp As Excel.application
Dim aFound As Boolean
 
Set xlApp = CreateObject("Excel.Application")
xlApp.Visible = True
xlApp.Workbooks.Open ("C:\Foldername\Day1.xls")
 
With Selection
    'Move the cursor to top of the document
    .HomeKey unit:=wdStory
aFound = True
I = 2
Do
    With .Find
        .Execute findtext:="Application:", MatchCase:=True, Forward:=True, Wrap:=wdFindStop
    If .Found Then
        I = I + 1
        Selection.MoveRight unit:=wdCell
        FinalText = Trim(Selection.Text)
        Debug.Print FinalText
        xlApp.Workbooks("Day1.xls").Sheets(1).Cells(I, 4).Value = FinalText
        aFound = True
    Else
        aFound = False
    End If
    End With
Loop Until aFound = False
End With
End Sub

Regards,

CS.

Alright I attached a copy of one of the pages in the word doc what it is doin is picking up the first thing that shows up after application and stops after only picking up the first page for xample I ran it and it gave me "Software/Hardware Status:" and that is the first word that shows in the next table because there is no words after application in this particular page and then it stops those anyone know why it is doin that