Counting style usage

[Ken]

I am trying to write code that will count the number of times a style
is used in a document.

The following code works some of the time but results in an endless
loop under some circumstances (the i < 1000 eventually exits the loop
if this happens). I have determined that the endless loop will occur
if the found text is within a table cell, is the last paragraph in the
cell and there is no paragraph character at the end of the text. I can
use .Information(wdWithInTable) to detect this and take appropriate
action.

However, there seems to be other circumstances when an endless loop
can occur.

Does anyone have a solution to this problem?

With tRange.Find
.ClearFormatting
.Style = “Normal” ‘ or whatever style is to be found
i = 0
testr = True
Do While testr And i < 1000
testr = .Execute(findtext:="", replacewith:="", MatchCase:=False,
_
Wrap:=wdFindStop, MatchWholeWord:=False, _
Forward:=True, Replace:=wdReplaceNone)
If testr Then i = i + 1
Loop
End With

 

[Greg Maxey]

Sub Test()
Dim i As Long
Dim oPar
For Each oPar In ActiveDocument.Range.Paragraphs
If oPar.Style.NameLocal = "Normal" Then
i = i + 1
End If
Next oPar
MsgBox i
End Sub

 

[Ken]

Greg

Your code does not work with character styles.

Find will search for character styles but I am having the problems
mentioned.

Ken

 

[Helmut Weber]

Hi Ken,

pretty complicated, I'd say.
Have a look at that one and note,
that the same style spanning over a paragraph mark
is counted twice as well as an empty cell,
formatted with that style, is counted as one occurence.

Sub Test4aab()
Dim rDcm As Range
Dim i As Long
Set rDcm = ActiveDocument.Range
With rDcm.Find
.Style = "WordsToInsert" ' or whatever style
i = 0
While .Execute And i < 1000
i = i + 1
' rDcm.Select
If rDcm.Information(wdWithInTable) Then
While rDcm.Characters.First.Previous.Style = "WordsToInsert"
_
And rDcm.Characters.First.Previous <> Chr(13) _
And rDcm.Characters.First.Previous <> Chr(7)
rDcm.start = rDcm.start - 1
Wend
If IsAtEndOfCell(rDcm) Then
rDcm.Collapse Direction:=wdCollapseEnd
' rDcm.Select
End If
End If
rDcm.Collapse Direction:=wdCollapseEnd
Wend
End With
MsgBox "Result = " & i
End Sub

Public Function IsAtEndOfCell(ByVal rtmp As Range) As Boolean
Dim l1 As Long
Dim l2 As Long
l1 = Len(rtmp.Text)
rtmp.End = rtmp.End + 1
l2 = Len(rtmp.Text)
If l2 = l1 + 2 Then IsAtEndOfCell = True
End Function


Watch out for false linebreaks by the newsreader.

--

Greetings from Bavaria, Germany

Helmut Weber, MVP WordVBA

Vista Small Business, Office XP

 

[Greg Maxey]

Try this.

Public Sub CountStyleUsage()
Dim oChr As Range
Dim oPar As Range
Dim i As Long
Dim j As Long
Dim pName As String
Dim pNameChar As String
pName = "Heading 2"
pNameChar = pName & " Char"
With ActiveDocument.StoryRanges(wdMainTextStory)
Set oPar = .Paragraphs(1).Range
Do
Select Case True
Case oPar.Style.NameLocal = pName
i = i + 1
oPar.Select
End Select
oPar.Collapse wdCollapseEnd
oPar.MoveEnd wdParagraph, 1
Loop Until oPar.End = .End
Set oChr = .Characters(1)
Do
Select Case True
Case oChr.Style = "Heading 2 Char"
If oChr.Next.Style.NameLocal <> pNameChar Then
j = j + 1
End If
End Select
oChr.Collapse wdCollapseEnd
oChr.MoveEnd wdCharacter, 1
Loop Until oChr.End = .End
End With
Set oPar = Nothing
Set oChr = Nothing
MsgBox pName & " style used " & i & " times. " & _
vbCr vbCr & pNameChar & " style used " & j & " times."
End Sub

 

[Ken]

Helmut

Thanks.

I have used your ideas which seem to have solved the problem with
table cells.

I am still getting the occasional endless loop outside of tables and I
am currently chasing them up.

Ken

 

[Helmut Weber]

Hi Ken,

make sure that the last paragraph mark in a doc,
the end-of-doc mark is not formatted in the
character style in question,

or add a test for end of doc:

Sub Test4aab()
Dim rDcm As Range
Dim i As Long
Set rDcm = ActiveDocument.Range
With rDcm.Find
.Style = "WordsToInsert" ' or whatever style
i = 0
While .Execute And i < 1000
i = i + 1
rDcm.Select
If rDcm.Information(wdWithInTable) Then
While rDcm.Characters.First.Previous.Style = "WordsToInsert"
_
And rDcm.Characters.First.Previous <> Chr(13) _
And rDcm.Characters.First.Previous <> Chr(7)
rDcm.start = rDcm.start - 1
Wend
If IsAtEndOfCell(rDcm) Then
rDcm.Collapse Direction:=wdCollapseEnd
rDcm.Select
End If
End If
rDcm.Collapse Direction:=wdCollapseEnd
' end of doc test
If rDcm.End = ActiveDocument.Range.End - 1 Then
GoTo finish
End If
Wend
End With
finish:
MsgBox "Result = " & i
End Sub


--

Greetings from Bavaria, Germany

Helmut Weber, MVP WordVBA

Vista Small Business, Office XP

 

[Ken]

Greg

The "Case xChr.style = ..." statements raised errors whenever a TOC
field is encountered.
I added an "on error resume next" statement to get the program working
although this adds to the count whenever an error occurs.

Your solution scans every character. With a 50 page test document the
program took 4 seconds in Word 2003 and over 5 minutes in Word 2007
which is impractical considering that I want to determine the count
for several styles.

The "Find" approach runs much faster and even in Word 2007 gives
results in few seconds.

 

[Greg Maxey]

Ken,

Yes, it seems Helmut and I discussed and compared a similar "speed" issue
involving Word2007 a few years back. It is in fact brutally slow as the
document get larger :-(

Thanks.

 

[Ken]

Helmut

I had determined that the problem was occurring at the end of the
document and you have given me the solution I was seeking.

Thanks

Ken

 

[Ken]

Greg

The speed issue also applies to Excel2007. Some VBA that I had used
for years in earlier versions of Excel is so slow in Excel2007 that it
is unusable.

Thanks for your help.

Ken