Macro very slow in Word 2003

[ckxplus]

Back in June, I posted a problem on this newsgroup about as macro that
searches for a regular pattern in table cells and defines tab
positions if the pattern is found (Thread 'find, format tabs and
replace in table cells'). Thanks to Helmut Weber, my initial attempt
was greatly improved and worked at an acceptable speed in Word 2000
(from 25 seconds on a 19 page document to .375 seconds!).

But now I've got Word 2003 and I'm also working on larger documents
(60 pages) and processing time has increased to 6 minutes. I suspect
that memory problems are playing up as well since another macro
creates garbage if run after this first one, whereas it runs perfectly
if I save and quit Word before running it. Does anyone have any
suggestions on how to improve the performance of this macro?

(From my posting on June 27: I've got tables with counts and
percentages in many of the table cells
in the form "35.3% (47/133)". I want the percentages to align so I
wrote a macro to define right-aligning tab positions at 40% and 100%
of the cells usable width and then insert a tab character between the
percentage sign and the opening parenthesis.)

Advance thanks for any help,
John Hendrickx

Public Sub TabsForPctAndCount()
Dim t As Single
t = Timer
Dim aRange As Range
Dim oCell As Cell
Dim UseableWidth As Single

Set aRange = ActiveDocument.Range
System.Cursor = wdCursorWait ' Displays the hourglass
Application.ScreenUpdating = False

With aRange.find
.Text = "([0-9.]{1,8}%)[ ]{1,5}\("
.Replacement.Text = "^t\1^t("
.MatchWildcards = True
While .Execute
If aRange.Information(wdWithInTable) Then
.Execute replace:=wdReplaceOne
Set oCell = aRange.Cells(1)
UseableWidth = _
oCell.Width - oCell.LeftPadding -
oCell.RightPadding
oCell.Range.ParagraphFormat.TabStops.ClearAll
oCell.Range.ParagraphFormat.TabStops.add _
Position:=UseableWidth * 0.4,
Alignment:=wdAlignTabRight
oCell.Range.ParagraphFormat.TabStops.add _
Position:=UseableWidth, Alignment:=wdAlignTabRight
aRange.Start = oCell.Range.End + 1
aRange.End = ActiveDocument.Range.End
End If
Wend
End With


System.Cursor = wdCursorNormal ' Normal cursor
Application.ScreenUpdating = True
StatusBar = "Macro TabsForPctAndCount completed."
MsgBox Timer - t
End Sub

 

[Helmut Weber]

Hi,

one hint would be,
to clear the undo stack, like
ActiveDocument.UndoClear
for each action in the loop.

Another one, to rewrite it all
for selection instead of range,
which in tables (!) is up to 50 times faster than range.

Just guesses, sorry.

I have no idea, what makes Word 2003
to behave so differently from 2000.

--
Greetings from Bavaria, Germany

Helmut Weber, MVP WordVBA

Win XP, Office 2003
"red.sys" & Chr$(64) & "t-online.de"

 

[ckxplus]

Hi,

one hint would be,
to clear the undo stack, like
ActiveDocument.UndoClear
for each action in the loop.

Another one, to rewrite it all
for selection instead of range,
which in tables (!) is up to 50 times faster than range.

Just guesses, sorry.

I have no idea, what makes Word 2003
to behave so differently from 2000.

Hi Helmut,

I decided to use selection instead of range, that speeded things up
tremendously, from 360 seconds down to 28 (on a 66 page document with
a lot of occurrences). The only downside is that the macro is now a
bit "scarier". It looks like your document is being eaten up when you
run it. But the results are fine so I can certainly live with that!
Thanks very much for your help.

New version:
Public Sub TabsForPctAndCount()
Dim t As Single
t = Timer
Dim oCell As Cell
Dim UseableWidth As Single

System.Cursor = wdCursorWait ' Displays the hourglass
StatusBar = "Defining tab positions in tables ..."

Application.ScreenUpdating = False

Selection.find.ClearFormatting

With Selection.find
.Text = "([0-9.]{1,8}%)[ ]{1,5}\("
.Replacement.Text = "^t\1^t("
.Forward = True
.Wrap = wdFindContinue
.MatchCase = False
.MatchWholeWord = False
.MatchAllWordForms = False
.MatchSoundsLike = False
.MatchWildcards = True
While .Execute
If Selection.Information(wdWithInTable) Then
.Execute replace:=wdReplaceOne
Set oCell = Selection.Cells(1)
UseableWidth = _
oCell.Width - oCell.LeftPadding -
oCell.RightPadding
oCell.Range.ParagraphFormat.TabStops.ClearAll
oCell.Range.ParagraphFormat.TabStops.Add _
Position:=UseableWidth * 0.4,
Alignment:=wdAlignTabRight
oCell.Range.ParagraphFormat.TabStops.Add _
Position:=UseableWidth, Alignment:=wdAlignTabRight
Selection.Collapse direction:=wdCollapseEnd
End If
Wend
End With

System.Cursor = wdCursorNormal ' Normal cursor
Application.ScreenUpdating = True
StatusBar = "Macro TabsForPctAndCount completed."
MsgBox Timer - t
End Sub