Microsoft Office Forums - View Single Post

gmayor · 07-23-2017, 04:02 AM

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:

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
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