Do Loop bug

[donlincolnmsof]

Hello

I have the following do loop, it processes all the data, but its crashed ON SELECTION.CUT ALMOST AT THE END OF THE LOOP.

A bit i understand there has to be some sort of check for terminate the do loop.

Any help will be appreciated.

Thanks.



Do

Selection.Find.ClearFormatting
With Selection.Find
.Text = "Add to watchlist"
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindContinue


.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
Selection.Find.Execute
Selection.Delete Unit:=wdCharacter, Count:=1
Selection.MoveUp Unit:=wdLine, Count:=2
Selection.EndKey Unit:=wdLine, Extend:=wdExtend
Selection.MoveLeft Unit:=wdCharacter, Count:=1, Extend:=wdExtend
Selection.Cut
Windows(1).Activate
Selection.Paste
Selection.TypeText Text:=vbTab
Selection.TypeParagraph
Windows(2).Activate

Loop Until Selection.Find.Found = False


Selection.HomeKey Unit:=wdStory
Windows(1).Activate
Selection.HomeKey Unit:=wdStory
Windows(2).Activate
Selection.HomeKey Unit:=wdStory

Do


Selection.Find.ClearFormatting
With Selection.Find
.Text = "TOTAL REVENUE"
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
Selection.Find.Execute
Selection.HomeKey Unit:=wdLine
Selection.EndKey Unit:=wdLine, Extend:=wdExtend
Selection.MoveLeft Unit:=wdCharacter, Count:=1, Extend:=wdExtend
Selection.Cut
Windows(1).Activate
Selection.EndKey Unit:=wdLine
Selection.TypeText Text:=vbTab
Selection.Paste
Selection.TypeParagraph
Selection.Delete Unit:=wdCharacter, Count:=1
Windows(2).Activate


Loop Until Selection.Find.Found = False

[gmayor]

Without a sample document to test your code, and no indication of what the code is supposed to do, in the absence of such a document, it is difficult to advise.

[donlincolnmsof]

Hello

Attached is the sample data file with macro. you can comment out the rest of the macro and run the macro just for the DO LOOP.

As you can see there are 2 LOOPS if the data can be extracted just by one loop then that would be better.

Thanks.

[gmayor]

While the first part of your code appears to copy the paragraph 2 paragraphs before the found paragraph i.e. Community Health Systems, Inc. (CYHHZ), to another document, it is not at all clear what the second part of the loop is supposed to do. Can you clarify?

There is only one instance of each string in the document. Is that always going to be the case?

[donlincolnmsof]

Well the 1st part SEARCHES FOR

ADD TO WATCHLIST (since its a unique code)

and then it deletes so the code disappears from the file and then goes up and cuts the company name and symbol and pastes it next window

when all this is done

then it goes to the top of the file in both file

then from the symbol file, its searches for TOTAL REVENUE and cuts the entire line and then pastes it right next to the symbol ( but before pasting it adds a TAB) then goes to the end of the line and then hit enter then delete to pull up the line and then hits end to go the end of the symbol ( TO GET READY FOR NEXT RECORD )

Hope this helps

problem that i have is that THE DO LOOP IS CRASHING.

Thanks.

[gmayor]

OK I get the first part. In your document it collects:
Community Health Systems, Inc. (CYHHZ)

That part is easy enough. What I don't understand is the second part; and your revised explanation doesn't make any sense, when related to the document you have provided as an example.

If you grab the line that contains TOTAL REVENUE and then grab the complete paragraph, then if the document is any indication, you are not actually collecting anything. Are you saying that the document is not representative and there is more data on the same line as TOTAL REVENUE missing from your example. That would make sense. In which case the following will work:

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

[donlincolnmsof]

its crashing at

oNewDoc.SaveAs FileName:=strPath, FileFormat:=12, AddToRecentFiles:=False

the other thing is how i suppose to run this macro

should i have both windows open 1) with the master data and the 2nd window blank so i t can extract from 1 and paste in the 2nd one.

btw i'm using word 2000 so DOCX i believe is for new version of files.

It would have been much easier if the DO LOOP code was just fixed in the file that i attached.

The macro that you have written is very sophisticated and advance for my knowledge.

Thanks a lot though for your help.

[donlincolnmsof]

Here is the output that i'm looking for

attached are both 1) macro file 2) the data file.

Thanks


Mexco Energy Corporation (MXC) Total Revenue 2,525.363 2,421.792 3,390.005
the Rubicon Project, Inc. (RUBI) Total Revenue 278,221 248,484 125,295
Liberty All-Star Growth Fund, Inc. (ASG) Total Revenue 985.629 28,621.59 13,942.108
Partner Communications Company Ltd. (PTNR) Total Revenue 921,000 1,057,000 1,131,000
SITO Mobile, Ltd. (SITO) Total Revenue 29,426.955 12,805.19 15,809.467
Echelon Corporation (ELON) Total Revenue 32,385 38,804 38,730
TerraForm Global, Inc. (GLBL) Total Revenue 214,317 124,116 39,449
Juniper Pharmaceuticals, Inc. (JNP) Total Revenue 54,573 38,287 33,393
Vivint Solar, Inc. (VSLR) Total Revenue 135,167 64,182 25,258

[gmayor]

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.

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

[donlincolnmsof]

Hello Gmayor

The macro that you wrote, It worked excellent, its LIGHTNING FAST.

The one I had It will have to cut and then paste in new window and slow, but the one you wrote is Really Really Fast.

I press the button and all the data is extracted in the 2nd window.

Thanks a lot for all your help

[donlincolnmsof]

Hello Gmayor

I wonder if you can help me with this macro, The macro is very similar to the earlier one except its cuts out only one block of text.

Its searches for the phone number with word " ANY CHARACTER " search, the format is in the macro and once it finds the phone number then it goes up 6 lines and cuts out a block of text.

As you can see in the output file 3 block of records are cut, ( once i have all the data like in this format then i do so search and replace to clean out the extra items from the file )

Any help would be greatly appreciated.

Thanks.

[donlincolnmsof]

Originally Posted by gmayor

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.

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

============

Hello gmayor

You wrote the above macro a while ago for me and i really appreciate that, i wonder if you can make a slight change to the macro.

The POST ON 07-23-2017, 10:38 AM

HAS THE FOLLOWING ATTACHMENT.

Attached Files
File Type: doc macro with data.doc (105.0 KB, 1 views)
File Type: doc output file.doc (20.0 KB, 2 views)

As it appears in the data file if you can also just extract the price part, that will really help me with this macro, since without the price, its been very difficult to lookup prices.

Mexco Energy Corporation (MXC)
NYSE MKT - NYSE MKT Delayed Price. Currency in USD
Add to watchlist
5.08+0.20 (+4.15%)
At close: 3:49PM EDT


I really appreciate all your help!!

Thanks a lot.!