Option Explicit

Sub Macro1()
Const strPath As String = "C:\Path\output data 0825.doc" 'The path where the data collection document is stored
Dim oRng As Range, oRng2 As Range
Dim oColl As Collection
Dim lngCol As Long
Dim strName As String
Dim strAddress As String
Dim strPostCode As String
Dim strPhone As String
Dim strEmail As String
Dim oTarget As Document
Dim vAdd As Variant
Dim oSource As Document

    Set oSource = ActiveDocument
    Const sNum As String = "0123456789"
    Set oRng = oSource.Range
    Set oColl = New Collection
    With oRng.Find
        Do While .Execute(FindText:="<a href=""/name/")
            On Error GoTo lbl_Exit
            If InStr(oRng, "<a href=""/name/") > 0 Then
                With oRng
                    .Collapse 0
                    .MoveEndUntil Chr(34)
                    strName = Replace(.Text, "-", " ")
                    .Collapse 0
                    .End = oSource.Range.End
                    .End = .Start + InStr(oRng, "<span itemprop=""streetAddress"">")
                    .MoveEndUntil sNum
                    .Collapse 0
                    .MoveEndUntil "<"
                    strAddress = .Text
                    .End = .Paragraphs(1).Range.End - 1
                    .MoveEndUntil sNum, wdBackward
                    .Collapse 0
                    .MoveStartUntil ">", wdBackward
                    strPostCode = .Text
                    .End = oSource.Range.End
                    .End = .Start + InStr(oRng, "<span itemprop=""telephone"">") + 26
                    .Collapse 0
                    .MoveEndWhile sNum & "-"
                    strPhone = .Text
                    .End = oSource.Range.End
                    .End = .Start + InStr(oRng, "<span itemprop=""email"">") + 22
                    .Collapse 0
                    .MoveEndUntil "<"
                    strEmail = .Text
                    oColl.Add strAddress & "|" & strPostCode & "|" & strName & "|" & strPhone & "|" & strEmail
                    .Collapse 0
                End With
            End If
        Loop
    End With
    If oColl.Count > 0 Then
        Set oTarget = Documents.Open(strPath)
        Set oRng2 = oTarget.Range
        For lngCol = 1 To oColl.Count
            vAdd = Split(oColl(lngCol), "|")
            oRng2.Collapse 0
            oRng2.Text = vbCr & vAdd(0) & " ,  " & vAdd(1) & vbTab & vAdd(2) & vbTab & vAdd(3) & vbTab & vAdd(4)
        Next lngCol
    End If
lbl_Exit:
    Set oSource = Nothing: Set oTarget = Nothing
    Set oRng = Nothing: Set oRng2 = Nothing
    Set oColl = Nothing
    Exit Sub
End Sub