Sub Macro1()
Dim oSource As Document
Dim oDoc As Document
Dim oRng As Range, oParaRng As Range
Dim lngP As Long
Dim sName As String, sAdd As String, sPhone As String, sExtract As String
    Set oSource = ActiveDocument
    Set oRng = oSource.Range
    Set oDoc = Documents.Add
    oDoc.Range.Font.Name = "Courier New"
    oDoc.Range.Font.Size = 10
    With oRng.Find
        Do While .Execute(FindText:="<div class=" & Chr(34) & "c-people-result__address" & Chr(34) & ">")
            oRng.MoveEnd wdParagraph, 2
            oRng.MoveStart wdParagraph, -4
            For lngP = 1 To oRng.Paragraphs.Count
                Select Case lngP
                    Case 1
                        Set oParaRng = oRng.Paragraphs(lngP).Range
                        oParaRng.End = oParaRng.End - 1
                        sName = Trim(Replace(oParaRng.Text, "</a>", ""))
                        sExtract = sName
                    Case 4
                        Set oParaRng = oRng.Paragraphs(lngP).Range
                        oParaRng.End = oParaRng.End - 1
                        oParaRng.MoveStartUntil ">"
                        oParaRng.Start = oParaRng.Start + 1
                        sAdd = Replace(oParaRng.Text, "</div>", "")
                        sExtract = sExtract & vbTab & sAdd
                    Case 5
                        Set oParaRng = oRng.Paragraphs(lngP).Range
                        oParaRng.End = oParaRng.End - 1
                        oParaRng.MoveStartUntil "("
                        sPhone = Replace(oParaRng.Text, "</div>", "")
                        sExtract = sExtract & vbTab & sPhone
                End Select
            Next lngP
            oDoc.Range.InsertAfter Trim(sExtract) & vbCr
            oRng.Collapse 0
        Loop
    End With
End Sub