excel macro search for word and copy sentence - macos

Question

I hope someone can help me with this problem.
I have two documents, one is Word and one is Excel. In the word file I have a list of items, for example:
Title Subtitle
1. Name
Address:
Phone number:
2. Name
Address:
Phone number:
3. Name
Address:
Phone number:
In the excel file I have a list of words in column D. What I want to do is take the word from column D, search for it in the Word document and then copy the sentence from after "Address: " to the ".", put that in Column C (i.e., one cell to the left), and then copy the sentence from after "Phone number: " to the "." and put it in Column B.
One of the parts I can't really wrap my head around is going from the first set of name, address and phone number to the next set.
Can someone help me with the macro on how to do this?
I have thought of expanding it from this:
Sub wordSearch()
' Purpose: display the text between (but not including)
' the words "Title" and "Address" if they both appear.
Dim rng1 As Range
Dim rng2 As Range
Dim strTheText As String
Set rng1 = ActiveDocument.Range
If rng1.Find.Execute(FindText:="Example:") Then
Set rng2 = ActiveDocument.Range(rng1.End, ActiveDocument.Range.End)
If rng2.Find.Execute(FindText:=".") Then
strTheText = ActiveDocument.Range(rng1.End, rng2.Start).Text
MsgBox strTheText
End If
End If
End Sub

Answer 1

As an example, the sub for Excel below gets whole text from catalog.doc located in the same folder as Excel file, parses text with RegExp, loops through contacts and puts it into the Dictionary, then loops through D2:D10 cells and assign appropriate data for matched names to C and B columns respectively. Tested in MS Office 2003, Windows 7 HB.
Option Explicit
Sub GetFromWord()
' Tools - References - add these:
' Microsoft Word 11.0 Object Library
' Microsoft VBScript Regular Expressions 5.5
' Microsoft Scripting Runtime
Dim strCont As String
Dim objCatalog As Scripting.Dictionary
Dim objMatch As IMatch2
Dim objElt As Range
With New Word.Application
.Documents.Open ThisWorkbook.Path & "\catalog.doc"
With .ActiveDocument.Range
.WholeStory
strCont = .Text
End With
.Quit
End With
Set objCatalog = New Scripting.Dictionary
With New RegExp
.Pattern = "\d+\.[ \t]*([^\n\r]*)\s*Address:[ \t]*([^\n\r]*)\s*Phone number:[ \t]*([^\n\r]*)\s*"
.Global = True
.MultiLine = True
.IgnoreCase = True
For Each objMatch In .Execute(strCont)
objCatalog.Add objMatch.SubMatches(0), Array(objMatch.SubMatches(1), objMatch.SubMatches(2))
Next
End With
For Each objElt In Range("D2:D10")
With objElt
If objCatalog.Exists(.Cells(1, 1).Value) Then
.Offset(0, -1) = objCatalog(.Cells(1, 1).Value)(0)
.Offset(0, -2) = objCatalog(.Cells(1, 1).Value)(1)
End If
End With
Next
End Sub
Note, that duplicated contacts in Word will result in error, no additional check implemented.
UPD: In case of any problems with early binding you can use late binding CreateObject(ProgID) as follows, but it isn't a best practice in VBA:
Option Explicit
Sub GetFromWordLBind()
Dim strCont As String
Dim objCatalog, objMatch, objElt As Object
With CreateObject("Word.Application")
.Documents.Open ThisWorkbook.Path & "\catalog.docx"
With .ActiveDocument.Range
.WholeStory
strCont = .Text
End With
.Quit
End With
Set objCatalog = CreateObject("Scripting.Dictionary")
With CreateObject("VBScript.RegExp")
.Pattern = "\d+\.[ \t]*([^\n\r]*)\s*Address:[ \t]*([^\n\r]*)\s*Phone number:[ \t]*([^\n\r]*)\s*"
.Global = True
.MultiLine = True
.IgnoreCase = True
For Each objMatch In .Execute(strCont)
objCatalog.Add objMatch.SubMatches(0), Array(objMatch.SubMatches(1), objMatch.SubMatches(2))
Next
End With
For Each objElt In Range("D2:D10")
With objElt
If objCatalog.Exists(.Cells(1, 1).Value) Then
.Offset(0, -1) = objCatalog(.Cells(1, 1).Value)(0)
.Offset(0, -2) = objCatalog(.Cells(1, 1).Value)(1)
End If
End With
Next
End Sub