Hello
The following macro was written by a member of this board a while back and while most of the structure of the macro would be same but the data extracted gets changed.
Name, address and phone numbers
I was wondering if any one can help me with this macro I will really appreciate it.
Attached are the word files for
1) Sample data to extract
2) output data.
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 was written.
--------------------------
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