Sub GetPhone()
  Dim aRng As Range, aDoc As Document, aDoc2 As Document
  Dim aRngInner As Range, sText As String, sTitle As String
  
  Set aDoc = ActiveDocument
  Set aRng = aDoc.Range
  With aRng.Find
    .ClearFormatting
    .Text = "\<\!doctype html\>*\</html\>"
    .Forward = True
    .Wrap = wdFindStop
    .MatchCase = False
    .MatchWildcards = True
    Do While .Execute = True
      'Use this range to find the first title instance inside it
      Set aRngInner = aRng.Duplicate
      With aRngInner.Find
        .Text = "\<title\>*\</title\>"
        .Forward = True
        .Wrap = wdFindStop
        .MatchCase = False
        .MatchWildcards = True
        If .Execute = True Then
          sTitle = aRngInner.Text
        Else
          sTitle = "Title Not Found"
        End If
      End With
      'Now use the same range to find all the phone numbers
      Set aRngInner = aRng.Duplicate
      With aRngInner.Find
        .Text = "[0-9]{3}[\) -]{1,2}[0-9]{3}-[0-9]{4}"
        .Forward = True
        .Wrap = wdFindStop
        .MatchCase = False
        .MatchWildcards = True
        Do While .Execute = True
          Debug.Print aRngInner.Text, sTitle
          sText = sText & vbCr & aRngInner.Text & vbTab & sTitle
          aRngInner.Collapse Direction:=wdCollapseEnd
          aRngInner.End = aRng.End
        Loop
      End With
      aRng.Collapse Direction:=wdCollapseEnd
      If Len(sText) > 0 Then sText = sText & vbCr
    Loop
  End With
  If Len(sText) > 0 Then
    Set aDoc2 = Documents.Add(Visible:=True)
    aDoc2.Range.Text = sText
  Else
    MsgBox "No hits"
  End If
End Sub