Microsoft Office Forums

Go Back   Microsoft Office Forums > Microsoft Word > Word VBA

Reply
 
LinkBack Thread Tools Display Modes
  #1  
Old 09-09-2017, 12:16 AM
donlincolnmsof donlincolnmsof is offline Windows 7 64bit Office 2003
Novice
 
Join Date: Oct 2011
Posts: 19
donlincolnmsof is on a distinguished road
Default Using Ranges in a Macro.

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
Attached Files
File Type: doc macro with data.doc (105.0 KB, 2 views)
File Type: doc output file.doc (21.0 KB, 2 views)

Last edited by macropod; 09-09-2017 at 11:24 PM. Reason: Added code tags
Reply With Quote
  #2  
Old 09-09-2017, 02:24 AM
gmayor's Avatar
gmayor gmayor is offline Windows 10 Office 2016
Expert
 
Join Date: Aug 2014
Posts: 2,227
gmayor is a jewel in the roughgmayor is a jewel in the roughgmayor is a jewel in the roughgmayor is a jewel in the rough
Default

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
__________________
Graham Mayor - MS MVP (Word)
Visit my web site for more programming tips and ready made processes www.gmayor.com
Reply With Quote
  #3  
Old 09-20-2017, 08:14 PM
donlincolnmsof donlincolnmsof is offline Windows 7 64bit Office 2003
Novice
 
Join Date: Oct 2011
Posts: 19
donlincolnmsof is on a distinguished road
Default

Great

Thanks a lot
Reply With Quote
  #4  
Old 11-07-2017, 08:10 PM
donlincolnmsof donlincolnmsof is offline Windows 7 64bit Office 2003
Novice
 
Join Date: Oct 2011
Posts: 19
donlincolnmsof is on a distinguished road
Default Extract Data

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
Attached Files
File Type: doc sample output.doc (19.0 KB, 0 views)
File Type: doc input file.doc (471.0 KB, 0 views)

Last edited by macropod; 11-07-2017 at 08:50 PM. Reason: Added code tags
Reply With Quote
Reply

Thread Tools
Display Modes


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


All times are GMT -7. The time now is 10:45 AM.


Powered by vBulletin® Version 3.8.1
Copyright ©2000 - 2017, Jelsoft Enterprises Ltd.
SEO by vBSEO ©2011, Crawlability, Inc.
MSOfficeForums.com is not affiliated with Microsoft