Do a text search throughout an entire document in VBA

[QK]

The code behind is pretty much standard (I just copy and paste).
Something very strange, the number of occurence for this search string is
correct.
But the insertion point (in my case the cursor) seems to be "frozen" at the
top of
the document!
Dim intFound As Integer
Dim ORng As Word.Range
Set ORng = Oword.ActiveDocument.Range
intFound = 0
With ORng.Find
.ClearFormatting
.Forward = True
.Text = "09 March 2006"
.Execute
Do While .Found = True
nStartPg = Oword.Selection.Information(wdActiveEndPageNumber)
intFound = intFound + 1

MsgBox "Found on page " & nStartPg & " " & intFound & " times",
vbOKOnly, "TEST"
.Execute
Loop
End With
MsgBox "'09 March 2006' Found " & intFound & " times", vbOKOnly, "TEST"
What's wrong with the insertion point, or with my code?!
Very desperate for this.

 

[Greg Maxey]

QK,

That doesn't really search throughout the entire document just the
storyrange containing the IP. While the code is pure spaghetti, I created a
Add-in that you might find helpful:

http://gregmaxey.mvps.org/Find_it_tool_bar.htm

To find "all" text using vba, see:

http://word.mvps.org/faqs/customization/replaceanywherecontent.htm

 

[QK]

Greg,

Thanks for your quick response.
I don't quite get this "storyrange" stuff (I'm new to this VBA with Word).
This is what I want:
1) I have a word doc (many pages).
2) some pages start with "09 March 2006" being the first non-blank text.
2.5) the 1st page ALWAYS has this text.
3) 3 lines below this "09 March 2006" is the name of a customer (can be
anything)
4) Upon finding this specific text, i.e. "09 March 2006",
5) I'll move 3 lines under to get to the customer string line & selected.
6) then assign a string variable strCust = .selection.text
7) all following pages BELONG to this customer until a match (09 March 2006)
is found.
In summary, I need to catpure:
i) How many customers and who they are
ii) how many pages per customer

How will this "spaghetti" code be enhanced to achieve this?
Must be done by weekend.

Many thanks
QK

 

[Greg]

QK,

For your purpose you don't have to worry about storyranges and the
speghetti code in my Add-In probably isn't what you need either.

I don't have time to work out all of the details for you right now, but
the reason your cursor stays put during your routine is because you are
using ranges. When you find the text you can then select it, move the
selection down 3 lines and then expand the selection to get your
customer data.

Play around with this:

Sub Test()
Dim intFound As Integer
Dim oRng As Word.Range
Dim nStartPg&
Set oRng = ActiveDocument.Range
intFound = 0
With oRng.Find
.ClearFormatting
.Forward = True
.Text = "09 March 2006"
While .Execute
If .Found Then
oRng.Select
nStartPg = Selection.Information(wdActiveEndPageNumber)
intFound = intFound + 1
Selection.Move Unit:=wdLine, Count:=3
Selection.Bookmarks("\Line").Select
MsgBox Selection.Text
MsgBox "Found on page " & nStartPg, vbOKOnly, "TEST"
End If
Wend
End With
MsgBox "'09 March 2006' Found " & intFound & " times", vbOKOnly, "Test"
End Sub

 

[Greg]

QK,

Here is a bit more. It seems to determine the number of pages that
each customers text takes up we are going to have to work form the end
of the document towards the front. I am not very experienced with
Collections, but here is a bit of code that adds the Customer Name and
the number of pages between customer names to a couple of collections
and then reports the results.

Sub Test()
Dim intFound As Integer
Dim oList As Collection, oPageCount As Collection
Dim oRng As Word.Range
Dim nStartPg&, oNumPages&
Dim oVar As Word.Variables
Dim myVar As Variable
Set oRng = ActiveDocument.Range
Set oList = New Collection
Set oPageCount = New Collection
Set oVar = ActiveDocument.Variables
intFound = 0
ActiveDocument.Bookmarks("\endofdoc").Select
oVar("myVar").Value =
ActiveDocument.ComputeStatistics(wdStatisticPages) + 1
With oRng.Find
.ClearFormatting
.Forward = False
.Text = "09 March 2006"
While .Execute
If .Found Then
oRng.Select
nStartPg = Selection.Information(wdActiveEndPageNumber)
intFound = intFound + 1
Selection.Move Unit:=wdLine, Count:=3
Selection.Bookmarks("\Line").Select
oList.Add Selection.Text
oNumPages = oVar("myVar").Value - nStartPg
oPageCount.Add oNumPages
oVar("myVar").Value = oVar("myVar").Value - oNumPages
End If
Wend
End With
Dim i&
For i = 1 To oList.Count
MsgBox oList(i) & oPageCount(i)
Next
End Sub

This is probably not a robust method and maybe someone will be along to
show us both how to use perhaps a two demensional array or perhaps a
class module to better track and use the data. Unfortunately I am
navigating shoal water here and could be running you aground ;-)

 

[Ed]

You're mixing Selection and Range. In a Range object, the Selection point
(cursor) doesn't move unless you select something.
nStartPg = Oword.Selection.Information(wdActiveEndPageNumber)
may not return a true number, because the selection point hasn't moved - the
Range object has.
Also, when using Find, the Range object changes from the whole range
searched to the Found range. I'm not real clear on all of this, but it's
trapped me several times.

This is very do-able.

This may not! (Just a warning!)

Try this ON A **COPY** OF YOUR INFORMATION. It is untested.

Sub XX_Test_FindAndPages()

Dim strCheck As String ' date to look for
Dim strCust As String ' customer name
Dim lngPages As Long ' number of pages
Dim lngCust As Long ' count of customers
Dim aryCust() ' array of customer names
Dim aryPgs() ' array of no. of pages
Dim x As Long, y As Long ' page number holders
Dim a As Long, b As Long ' number holders

lngCust = 0
a = ActiveDocument.BuiltInDocumentProperties(wdPropertyPages)
strCheck = InputBox("What date are you searching for?")

Selection.HomeKey wdStory

With Selection.Find
.ClearFormatting
If .Execute(FindText:=strCheck, MatchWholeWord:=False, _
Forward:=True, Wrap:=wdFindStop) = True Then
' found a match
' select customer name
lngCust = lngCust + 1
Selection.HomeKey wdLine
Selection.MoveDown wdLine, 3
Selection.EndKey wdLine, Extend
strCust = Selection.Text
' write into array
ReDim Preserve aryCust(lngCust)
aryCust(lngCust) = strCust
' get page number
y = x
x = Selection.Information(wdActiveEndPageNumber)
If y <> 0 Then
If x <> a Then
ReDim Preserve aryPgs(lngCust)
aryPgs(lngCust) = y - x
Else
ReDim Preserve aryPgs(lngCust)
aryPgs(lngCust) = a
End If
End If
End With

For b = 1 To lngCust
MsgBox aryCust(b)
MsgBox aryPgs(b)
Next b

End Sub

 

[Ed]

Well, gee - I ~thought~ I had something. Might be a good start, but it's
not going to do it for you right now. I've got a few more hours before I
go - I'll keep playing and see if I can get something.
Ed

 

[Jezebel]

I'd approach it like this ---

1. Create an array containing the start and end points of the range for each
customer --

Dim pRange As Word.Range
Dim pCustomers(1 To 1000, 1 To 2) as long 'Use some number that
is more than maximum you're likely to meet
Dim pCount As Long

Set pRange = ActiveDocument.Content
With pRange.Find
.Text = "09 March 2006"
Do While .Execute
pCount = pCount + 1
pCustomers(pCount, 1) = pRange.Start 'Start
of range for the customer
If pCount > 1 Then
pCustomers(pCount - 1, 2) = pRange.Start - 1 'End of
range for the customer
End If
Loop
End With
pCustomers(pCount, 2) = ActiveDocument.Content.End 'End of range for
the last customer


2. Output the values you want

NumberOfCustomers = pCount


Customer name is the third paragraph of the range for the customer
Page count is the page number at the end of the range, minus the page number
at the start of the range, plus one

For pIndex = 1 to pCount
CustomerName = ActiveDocument.Range(pCustomers(pIndex,1),
pCustomers(pIndex,2)).Paragraphs(3).Range.Text
NumberOfPages = ActiveDocument.Range(pCustomers(pIndex,2),
pCustomers(pIndex,2)).Information(wdActiveEndPageNumber) -
ActiveDocument.Range(pCustomers(pIndex,1),
pCustomers(pIndex,1)).Information(wdActiveEndPageNumber) + 1
Next

 

[Ed]

Okay - Here's what I've got. (Personally, though, I'd go with Jezebel's
code. She knows a whole lot more about what she's doing than me.)

Ed

Sub XX_Test_FindAndPages()

Dim strCheck As String ' date to look for
Dim strCust As String ' customer name
Dim lngPages As Long ' number of pages
Dim lngCust As Long ' count of customers
Dim aryCust() ' array of customer names
Dim aryPgs() ' array of no. of pages
Dim x As Long, y As Long ' page number holders
Dim a As Long, b As Long ' number holders
Dim bolEndOfDoc ' True if no match found

lngCust = 0
a = ActiveDocument.BuiltInDocumentProperties(wdPropertyPages)
strCheck = InputBox("What date are you searching for?")

Selection.HomeKey wdStory

Do
bolEndOfDoc = True
With Selection.Find
.ClearFormatting
If .Execute(FindText:=strCheck, MatchWholeWord:=False, _
Forward:=True, Wrap:=wdFindStop) = True Then
' found a match
bolEndOfDoc = False
' select customer name
lngCust = lngCust + 1
Selection.HomeKey wdLine
Selection.MoveDown wdLine, 3
Selection.EndKey wdLine, wdExtend
strCust = Selection.Text
' write into array
ReDim Preserve aryCust(lngCust)
aryCust(lngCust) = strCust
' get page number
y = x
x = Selection.Information(wdActiveEndPageNumber)
'If this is the first find, then loop again
' else subtract page numbers and add to array
If lngCust <> 1 Then
ReDim Preserve aryPgs(lngCust - 1)
aryPgs(lngCust - 1) = x - y
End If
Selection.Collapse wdCollapseEnd
End If
End With
Loop While bolEndOfDoc = False

' write last page quantity to array
ReDim Preserve aryPgs(lngCust)
aryPgs(lngCust) = a - x

' Show values
For b = 1 To lngCust
MsgBox "Customer No. " & b & _
", " & aryCust(b) & _
", had " & aryPgs(b) & _
" pages of information."
Next b

End Sub

 

[Greg]

Jezebel,

I get an error out of range. When I step through the code it is
generated on the long
NumberOfPages line for the last customer.

I cann't seem to find out why it is being generated.

 

[Jezebel]

Try changing the end of range value from Content.End to Content.End - 1

 

[Greg]

Yep, just coming back to tell you that is what I just discovered. I
mean that really ;-)

 

[QK]

Ed,
You don't need to be so humble to yourself.
Your code DOES exactly what I want (-:
(FYI : I didn't find Jezebel's code at all)
But one little tricky Maths behind of the code:
- when it comes to the LAST customer for his/her page count,
we need to ADD ONE, i.e (a - x) + 1, rather
(NB: this is just the beginning of my task, still a long long way for me to
go)
I/we meet the dead line.
Ed, you are a LEGEND!
Many thanks
QK

 

[Ed]

Your code DOES exactly what I want (-:

I/we meet the dead line.
Many thanks

You're welcome. I'm glad I could help. It's a wonderful feeling to be on
the giving side for a change!

Ed

 

[QK]

Ed,

I have hit some problem today in automating Word within VBA.
While this "search and get customer info loop" is busy at the moment,
the user open/edit/save/disgard another Word doc interactively.
At this stage the "automated" word session prompts for "save/cancel",
what's more the VB logic (I've put all these customer names/page counts, etc
into a table) gets "screw up"!
How can VBA "manage" the automated session among the others (fired up by
user)?
Ed, should I start a new thread for this one?
QK

 

[Ed]

Yes - probably best to start a new thread. This one's getting kind of "down
there", and you and I may be the only ones still watching it! 8>)

Also post the entire code, or as much as is relevant to the error. That way
we can see what interactions are causing problems.

Ed