View Single Post
 
Old 08-31-2019, 05:27 AM
gmayor's Avatar
gmayor gmayor is offline Windows 10 Office 2016
Expert
 
Join Date: Aug 2014
Posts: 4,137
gmayor has much to be proud ofgmayor has much to be proud ofgmayor has much to be proud ofgmayor has much to be proud ofgmayor has much to be proud ofgmayor has much to be proud ofgmayor has much to be proud ofgmayor has much to be proud ofgmayor has much to be proud of
Default

This type of data recovery is highly document dependent but based on your sample, the following will recover the data and write it to your output document. If the document layout changes then it won't work.

Code:
Option Explicit

Sub Macro1()
Const strPath As String = "C:\Path\output data 0825.doc" 'The path where the data collection document is stored
Dim oRng As Range, oRng2 As Range
Dim oColl As Collection
Dim lngCol As Long
Dim strName As String
Dim strAddress As String
Dim strPostCode As String
Dim strPhone As String
Dim strEmail As String
Dim oTarget As Document
Dim vAdd As Variant
Dim oSource As Document

    Set oSource = ActiveDocument
    Const sNum As String = "0123456789"
    Set oRng = oSource.Range
    Set oColl = New Collection
    With oRng.Find
        Do While .Execute(FindText:="<a href=""/name/")
            On Error GoTo lbl_Exit
            If InStr(oRng, "<a href=""/name/") > 0 Then
                With oRng
                    .Collapse 0
                    .MoveEndUntil Chr(34)
                    strName = Replace(.Text, "-", " ")
                    .Collapse 0
                    .End = oSource.Range.End
                    .End = .Start + InStr(oRng, "<span itemprop=""streetAddress"">")
                    .MoveEndUntil sNum
                    .Collapse 0
                    .MoveEndUntil "<"
                    strAddress = .Text
                    .End = .Paragraphs(1).Range.End - 1
                    .MoveEndUntil sNum, wdBackward
                    .Collapse 0
                    .MoveStartUntil ">", wdBackward
                    strPostCode = .Text
                    .End = oSource.Range.End
                    .End = .Start + InStr(oRng, "<span itemprop=""telephone"">") + 26
                    .Collapse 0
                    .MoveEndWhile sNum & "-"
                    strPhone = .Text
                    .End = oSource.Range.End
                    .End = .Start + InStr(oRng, "<span itemprop=""email"">") + 22
                    .Collapse 0
                    .MoveEndUntil "<"
                    strEmail = .Text
                    oColl.Add strAddress & "|" & strPostCode & "|" & strName & "|" & strPhone & "|" & strEmail
                    .Collapse 0
                End With
            End If
        Loop
    End With
    If oColl.Count > 0 Then
        Set oTarget = Documents.Open(strPath)
        Set oRng2 = oTarget.Range
        For lngCol = 1 To oColl.Count
            vAdd = Split(oColl(lngCol), "|")
            oRng2.Collapse 0
            oRng2.Text = vbCr & vAdd(0) & " ,  " & vAdd(1) & vbTab & vAdd(2) & vbTab & vAdd(3) & vbTab & vAdd(4)
        Next lngCol
    End If
lbl_Exit:
    Set oSource = Nothing: Set oTarget = Nothing
    Set oRng = Nothing: Set oRng2 = Nothing
    Set oColl = Nothing
    Exit Sub
End Sub
__________________
Graham Mayor - MS MVP (Word) (2002-2019)
Visit my web site for more programming tips and ready made processes www.gmayor.com
Reply With Quote