Microsoft Office Forums - View Single Post

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