Difficulty with sequential Find

[Demyan]

Hi
Imagine a collection of personal data that includes, for each individual, his name (preceded by tag 'Name:'), his age (preceded by tag 'Age:'), and misc. stuff in between. I need to extract names and ages. I write a macro that loops over the following step
1. Find 'Name:'; retrieve the following word (name), paste it into output fil
2. Find 'Age:'; retrieve the following word (age), paste it into output file
(Code is attached below). It doesn't work: throughout all attempted tweaks, age is either not found, or found once, for person 1, and then repeated for all individuals. I am aware of Find's redefining Selection in case of a successful search, but both searches in my macro run in ActiveDocument.Content
A seemingly simple, but baffling task..I would be extremely grateful for a helpful suggestion
Thank you

Sub ExtractLabels(
Set DocIn = ActiveDocumen
Set ConIn = DocIn.Conten

Set DocOut = Documents("test"
Set ConOut = DocOut.Conten

Set WdBefore = ConIn.Fin
StopFlag =
Do While StopFlag =
'Find the word 'Name:
With WdBefor
.ClearFormattin
.Text = "Name:
.Forward = Tru
.Execut
End Wit
If WdBefore.Found = True The
'Record nam
ConOut.InsertAfter Text:=ConIn.Next(Unit:=wdWord)
'Find the word 'Age:
WdBefore.Execute FindText:="Age:", Forward:=Tru
If WdBefore.Found = True The
'Record the variable labe
ConOut.InsertAfter Text:=Chr(34) & WdBefore.Parent.Next(Unit:=wdWord, Count:=1) & Chr(34) & vbC
Els
StopFlag =
End I
Els
StopFlag =
End I
Loo
End Su

 

[Helmut Weber]

Hi Demyan,
may I propose a quite different approach,
your code seems a bit complicated to me.
I assume that "Name: " and "Age: " are found
in exactly the same number, and that there is
always a name and a number and that neither
name nor number contain a space.
Public Function Countstr(s$) As Long
Dim i As Long
Dim r As Range
Set r = ActiveDocument.Range
With r.Find
.Text = s$
.Execute
End With
While r.Find.Found
i = i + 1
r.Find.Execute
Wend
Countstr = i
End Function
Sub ExtractLabels()
Dim r As Range
Dim n As Integer ' a number
Dim l As Integer ' length of string
Dim p As Integer ' position instring
Dim i As Integer ' a counter
n = Countstr("Name: ")
ReDim ArNam(n) As String
ReDim ArAge(n) As String

Set r = ActiveDocument.Range
With r.Find
.Text = "Name: *>"
.MatchWildcards = True
.Execute
End With
While r.Find.Found
i = i + 1
l = Len(r.Text)
p = InStr(r.Text, " ")
ArNam(i) = Right(r.Text, l - p)
Debug.Print i & " " & ArNam(i)
r.Find.Execute
Wend
i = 0
Set r = ActiveDocument.Range
With r.Find
.Text = "Age: *>"
.MatchWildcards = True
.Execute
End With
While r.Find.Found
i = i + 1
l = Len(r.Text)
p = InStr(r.Text, " ")
ArAge(i) = Right(r.Text, l - p)
Debug.Print i & " " & ArAge(i)
r.Find.Execute
Wend
End Sub
The arrays contain names and age.

Greetings from Bavaria, Germany
Helmut Weber
"red.sys" & chr$(64) & "t-online.de"
Word 97, NT 4.0

 

[Demyan]

Vielen Dank, Helmut!