Sub CopyNamesToExcel()
Dim oTable As Table
Dim oRng As Range
Dim xlApp As Object
Dim xlBook As Object
Dim xlSheet As Object
Dim xlCell As Object
Dim i As Integer, j As Integer
Dim sName As String
    On Error Resume Next
    Set xlApp = GetObject(, "Excel.Application")
    If Err Then
        Set xlApp = CreateObject("Excel.Application")
    End If
    On Error GoTo 0
    Set xlBook = xlApp.Workbooks.Add
    Set xlSheet = xlBook.Sheets(1)
    xlApp.Visible = True
    'Set xlCell = xlSheet.Range("A1")
    'xlCell.value = "Name"
    'j = 2
    j = 1
    For Each oTable In ActiveDocument.Tables
        Set oRng = oTable.Cell(1, 2).Range
        oRng.End = oRng.End - 1
        If InStr(1, oRng.Text, "NAMES OF PERSON") > 0 Then
            sName = Replace(oRng.Text, "NAMES OF PERSON", "")
            sName = Replace(sName, "VOLUNTARIY RETIRED", "")    '? Spelling
            sName = Replace(sName, "VOLUNTARILY RETIRED", "")
            sName = Replace(sName, Chr(13), "")
            Set xlCell = xlSheet.Range("A" & j)
            xlCell.value = Trim(sName)
            j = j + 1
        End If
    Next oTable
End Sub