Sub CopyNamesToExcel()
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
    For i = ActiveDocument.Paragraphs.Count To 1 Step -1
        If InStr(1, ActiveDocument.Paragraphs(i).Range.Text, "Name of person") > 0 Then
            Set oRng = ActiveDocument.Paragraphs(i).Range
            oRng.MoveStartUntil "n"
            oRng.Start = oRng.Start + 1
            oRng.End = oRng.End - 1
            sName = Trim(Replace(oRng.Text, Chr(34), ""))
            Set xlCell = xlSheet.Range("A" & j)
            xlCell.value = sName
            j = j + 1
        End If
    Next i
End Sub