Do Loop bug

gmayor · #9 07-23-2017, 08:17 PM

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

Similar Threads
Thread	Thread Starter	Forum	Replies	Last Post
Macro Loop Help	Twizzle008	Word VBA	15	09-18-2015 03:20 PM
Loop - Row increment	jrt	Excel Programming	1	04-16-2015 01:46 PM
What's wrong with my loop?	Irrma	Word VBA	2	06-17-2014 06:25 AM
How to a For loop in VBA	Jennifer Murphy	Word VBA	1	01-29-2013 03:30 AM
How to use for loop in formula in VBA?	tinfanide	Excel Programming	1	12-06-2011 08:33 AM