It really helps prevent a waste of time when you supply the right information in the first place and it would have been impossible to debug your code without access to the correct document, however flitting back and forth between documents and selections is not a good way to proceed. Use ranges instead.
To achieve the required output from the revised document you need to modify the code as follows. The second loop must be run inside the first one when there is more than one item to collect.
The document to be processed must be the active document when the macro is run. The other named document can be open or closed, it doesn't matter as the process opens it.
I don't have the means to check the code in Word 2000, but I have modified the line to save the document to the desktop and that should now work. If you have not already done so delete the document created by the earlier macro before running this one.
I have not extracted the blue text at the end of your output document, which bears no relationship to your code. If you want that, it is a simple addition.
Code:
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, oFound 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.doc" '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
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)
Set oFound = oRng
oFound.End = oDoc.Range.End
With oFound.Find
Do While .Execute(FindText:=vFind(1))
oFound.End = oFound.Paragraphs(1).Range.End - 1
Set oRng2 = oNewDoc.Range
oRng2.End = oRng2.End - 1
oRng2.Collapse 0
oRng2.Text = vbTab & oFound.Text & vbCr
oRng.Collapse 0
Exit Do
Loop
End With
oRng.Collapse 0
Loop
End With
With oNewDoc.Range
.ParagraphFormat.TabStops.ClearAll
.ParagraphFormat.TabStops.Add CentimetersToPoints(6.5)
.ParagraphFormat.SpaceAfter = 0
.Font.Name = "Arial"
.Font.Size = 8
End With
'oNewDoc.Close wdSaveChanges 'Optional
lbl_Exit:
Set fso = Nothing
Set oDoc = Nothing
Set oNewDoc = Nothing
Set oRng = Nothing
Set oRng2 = Nothing
Set oFound = Nothing
Exit Sub
End Sub