Using Ranges in a Macro.

donlincolnmsof · #1 09-09-2017, 12:16 AM

Hello

The following macro was written by a member of this board a while back and I wanted to amend the macro to include the price, I was wondering if any one can help me with this macro I will really appreciate it.

Thanks.

Attached Files
macro with data.doc
output file.doc

As it appears in the data file the price part needed extraction, 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.!

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

gmayor · #2 09-09-2017, 02:24 AM

I suspect what you require is

Code:

Option Explicit

Sub Macro1()
'Graham Mayor - http://www.gmayor.com - Last updated - 09 Sep 2017
Dim oDoc As Document
Dim oNewDoc As Document
Dim oRng As Range, oRng2 As Range, oFound As Range
Dim oPrice 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))
            Set oPrice = oRng.Paragraphs.Last.Range.Next.Paragraphs(1).Range
            oPrice.End = oPrice.End - 1
            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 & vbTab & oPrice.Text & vbCr
                    oRng.Collapse 0
                    Exit Do
                Loop
            End With
            oRng.Collapse 0
        Loop
    End With
    With oNewDoc.Range
        .PageSetup.LeftMargin = CentimetersToPoints(1)
        .PageSetup.RightMargin = CentimetersToPoints(1)
        .ParagraphFormat.TabStops.ClearAll
        .ParagraphFormat.TabStops.Add CentimetersToPoints(6.5)
        .ParagraphFormat.TabStops.Add CentimetersToPoints(13)
        .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 · #3 09-20-2017, 08:14 PM

Great

Thanks a lot

donlincolnmsof · #4 11-07-2017, 08:10 PM

Hello Gmayor

You wrote the following macro for me a while ago and i was wondering if you can modify this to extract

Name, address and phone numbers

I think structure is almost same, just have to change some of the items in it.

Attached are the word files for

1) Sample data to extract
2) output data.

I will really appreciate all your help.

Data block where text in the sample data file that has the following format.
-----------------------------------------------------------------------------------

Code:

                                John C Sechser                            </a>
                        </h3>

                                                    <div class="c-people-result__address">5288 Cedar RD, Saint Augustine, FL 32080</div>
                                                                            <div class="c-people-result__phone">(407) 489-4431</div>

Macro that you wrote.
------------------------

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
Charting variable ranges	mreynolds1775	Excel	4	09-21-2017 12:26 AM
Named Ranges Help	SavGDK	Excel	5	05-01-2017 09:41 AM
Help Needed with Macro to Change Formulas to Text Using Ranges	rsrasc	Excel Programming	2	11-29-2016 02:31 PM
Take String of numbers, expand ranges, sort, then compress back into ranges	AustinBrister	Word VBA	19	08-22-2016 05:18 PM
Dynamic chart ranges	GlowingApple	Excel	1	02-17-2016 07:18 PM