Option Explicit

Sub Macro1()
'Graham Mayor - http://www.gmayor.com - Last updated - 23 Jul 2017
Dim oDoc As Document
Dim oNewDoc As Document
Dim oRng As Range, oRng2 As Range
Dim vFind As Variant
Dim fso As Object
Dim strPath As String
Const strFind As String = "Add to watchlist|TOTAL REVENUE"

    strPath = Environ("USERPROFILE") & "\Desktop\DataExtract.docx"     'The name of the document to save the extract
    Set fso = CreateObject("Scripting.FileSystemObject")
    vFind = Split(strFind, "|")
    Set oDoc = ActiveDocument
    If fso.FileExists(strPath) Then
        Set oNewDoc = Documents.Open(FileName:=strPath, AddToRecentFiles:=False)
    Else
        Set oNewDoc = Documents.Add
        oNewDoc.SaveAs FileName:=strPath, FileFormat:=12, AddToRecentFiles:=False
    End If
    Set oRng = oDoc.Range
    With oRng.Find
        Do While .Execute(FindText:=vFind(0))
            oRng.MoveStart wdParagraph, -2
            oNewDoc.Range.InsertAfter _
                    Left(oRng.Paragraphs(1).Range.Text, _
                         Len(oRng.Paragraphs(1).Range.Text) - 1)
            oRng.Collapse 0
        Loop
    End With
    Set oRng = oDoc.Range
    With oRng.Find
        Do While .Execute(FindText:=vFind(1))
            oRng.End = oRng.Paragraphs(1).Range.End - 1
            Set oRng2 = oNewDoc.Range
            oRng2.End = oRng2.End - 1
            oRng2.Collapse 0
            oRng2.Text = vbTab & Trim(Replace(LCase(oRng.Text), _
                                              LCase(vFind(1)), "")) & vbCr
            oRng.Collapse 0
        Loop
    End With
    oNewDoc.Close wdSaveChanges
lbl_Exit:
    Set fso = Nothing
    Set oDoc = Nothing
    Set oNewDoc = Nothing
    Set oRng = Nothing
    Set oRng2 = Nothing
    Exit Sub
End Sub