Retrieveing email addresses from Word Doc

[Ray C]

I need to extract telephone numbers from a Word document and insert them in
Excel. So I decided to search for the area code (450). However my loop that
executes the Find method doesn't stop, so I'm stuck in a loop.
Can anyone tell me what I'm doing wrong?

For Each rng In objDocument.StoryRanges
With rng.Find
.ClearFormatting
.Text = "450"
.Wrap = wdFindStop
.Forward = True
End With
Do Until rng.Find.Execute = False
rng.Expand Unit:=wdSentence
myArray = Split(rng.Text, " ", -1, vbTextCompare)
For i = 0 To UBound(myArray)
If InStr(1, myArray(i), "450", vbTextCompare) <> 0 Then
'Insert into excel cell
End If
Next i
Loop
Next rng

 

[Jean-Guy Marcil]

I need to extract telephone numbers from a Word document and insert them in
Excel. So I decided to search for the area code (450). However my loop that
executes the Find method doesn't stop, so I'm stuck in a loop.
Can anyone tell me what I'm doing wrong?

For Each rng In objDocument.StoryRanges
With rng.Find
.ClearFormatting
.Text = "450"
.Wrap = wdFindStop
.Forward = True
End With
Do Until rng.Find.Execute = False
rng.Expand Unit:=wdSentence
myArray = Split(rng.Text, " ", -1, vbTextCompare)
For i = 0 To UBound(myArray)
If InStr(1, myArray(i), "450", vbTextCompare) <> 0 Then
'Insert into excel cell
End If
Next i
Loop
Next rng

From looking at your code, I guess the problem is here:

Do Until rng.Find.Execute = False
rng.Expand Unit:=wdSentence

You are redefining "rng", so now, the serach is looking at that sentence
over and over.

Work with a duplicate so that you do not touch the original range (the
document range). Try this (untested):


Dim rngStory As Range
Dim objDocument As Document
Dim myArray() As String
Dim i As Long

Set objDocument = ActiveDocument

For Each rngStory In objDocument.StoryRanges
With rngStory.Find
.ClearFormatting
.Text = "450"
.Wrap = wdFindStop
.Forward = True
End With
Do Until rngStory.Find.Execute = False
With rngStory.Duplicate
.Expand Unit:=wdSentence
myArray = Split(.Text, " ", -1, vbTextCompare)
For i = 0 To UBound(myArray)
If InStr(1, myArray(i), "450", vbTextCompare) <> 0 Then
'Insert into excel cell
End If
Next i
End With
Loop
Next