unable to extract contents from word to excel

[Kulasekaran]

Hi,

I am able to copy the contents of the values that is extracted from field in word documents to excel right now and i am trying to extract the contents from the word documents based on specific titles and their corresponding contents.
i have tried out with the following code, with the word properties for extracting the title and unable to extract the relevant contents.
I have attached a sample Document where the text highlighted in green is the title(where the last few numbers will be changing) extracted and pasted into a CELL in excel and texts that is highlighted in yellow is the content that is to be extract corresponding to the title and extract/ copy to a CELL in excel.

Sub InsertRow()
Dim WordApp As Object
On Error GoTo ReturnError
' Check if Word is already open
Set WordApp = GetObject(, "Word.Application")
WordApp.ActiveDocument.Content.Select
With WordApp.Selection.Find
.Text = "CA-PTS-ADIRU-121"
MsgBox .Text
.Wrap = wdFindStop
End With
If WordApp.Selection.Find.Execute Then
WordApp.Selection.InsertRowsBelow 1
End If
Exit Sub
ReturnError:
End Sub
[COLOR=#333333]
[/COLOR]

The below code is copying the contents from Word FIELds and its corresponding values to excel

Sub New_Excel()

  Dim xlApp As Object
  Dim wbExcel As Object
  Dim tSheet As Worksheet
  Dim TxtRng  As Range
  Dim bFileSaveAs As Boolean
  Dim oSheet As Object
  Dim oWorkbook As Object 'Excel.Workbook
   
  
  Set xlApp = CreateObject("Excel.Application")
  Set wbExcel = xlApp.Workbooks.Add
  'bFileSaveAs = xlApp.Dialogs(xlDialogSaveAs).Show
   xlApp.Visible = True
  Set oSheet = xlApp.Sheets("Sheet1")
   
   oSheet.Cells(1, 1).Value = "Requirement number"
   oSheet.Cells(1, 2).Value = "Requirement"
   oSheet.Cells(1, 3).Value = "Assumptions"
   oSheet.Cells(1, 4).Value = "Additional info"
   oSheet.Cells(1, 5).Value = "Stake holder"
   oSheet.Cells(1, 6).Value = "Source"
   oSheet.Cells(1, 7).Value = "Link To"
   oSheet.Cells(1, 8).Value = "Level"
   oSheet.Cells(1, 9).Value = "Applicable SA"
   oSheet.Cells(1, 10).Value = "Applicable LR"
   oSheet.Cells(1, 11).Value = "Applicable A380"


   oSheet.Columns(1).AutoFit
   oSheet.Columns(2).AutoFit
   oSheet.Columns(3).AutoFit
   oSheet.Columns(4).AutoFit
   oSheet.Columns(5).AutoFit
   oSheet.Columns(6).AutoFit
   oSheet.Columns(7).AutoFit
   oSheet.Columns(8).AutoFit
   oSheet.Columns(9).AutoFit
   oSheet.Columns(10).AutoFit
   oSheet.Columns(11).AutoFit
  
   Dim ofld As Field
    Dim oPara As Range
    Dim A As Variant
    Set oPara = ActiveDocument.Paragraphs(1).Range
    oPara.End = oPara.End - 1
    oPara.MoveStartUntil Chr(9)
    oPara.Start = oPara.Start + 1
    MsgBox oPara.Text
    For Each ofld In ActiveDocument.Fields
        If ofld.Type = wdFieldQuote Then
            Select Case True
            Case InStr(1, ofld.Code, "Rationale:")
            MsgBox GetValue(ofld)
            Case InStr(1, ofld.Code, "Assumptions:")
                MsgBox GetValue(ofld)
            Case InStr(1, ofld.Code, "Additional info:")
                MsgBox GetValue(ofld)
            Case InStr(1, ofld.Code, "Author:")
                MsgBox GetValue(ofld)
            Case InStr(1, ofld.Code, "Creation date")
                MsgBox GetValue(ofld)
            Case InStr(1, ofld.Code, "Stakeholder:")
                MsgBox GetValue(ofld)
            Case InStr(1, ofld.Code, "Source:")
                MsgBox GetValue(ofld)
            Case InStr(1, ofld.Code, "Link to:")
                MsgBox GetValue(ofld)
            Case InStr(1, ofld.Code, "Maturity")
                MsgBox GetValue(ofld)
            Case InStr(1, ofld.Code, "Applicable SA:")
                MsgBox GetValue(ofld)
            Case InStr(1, ofld.Code, "Applicable LR:")
                MsgBox GetValue(ofld)
            Case InStr(1, ofld.Code, "Applicable A380:")
                MsgBox GetValue(ofld)
            End Select
        End If
    Next ofld
lbl_Exit:
    Set ofld = Nothing
    Set oPara = Nothing
    Exit Sub


   


End Sub


Private Function GetValue(ofld As Field) As String
    Dim oPara As Range
    Set oPara = ofld.Result.Paragraphs(1).Range
    oPara.End = oPara.End - 1
    oPara.Start = ofld.Result.End + 1
    GetValue = oPara.Text
lbl_Exit:
    Exit Function
End Function


[COLOR=#333333]
[/COLOR]

please any one can help me out. Thanks in advance.