Macro runs slow due to tables

[Antigone]

The macro I've written below does add a comment to Bold FlushHeads, and does
not insert comment when range is found in a table. However the macro takes a
long time to run because it hits on each cell in a table. I've spent a week
now rewritting it 20+ times with different logic. Such as if paragraph is in
a table go to end of table and continue, if not in a table and meets the
conditions add the comment etc. None of my attempts work. Can someone steer
me in the right direction?

Regards
~Antigone
------------------------------------------------------------------------------
-------

Sub findboldheadsFv11()
' works on getting all Bold Flushheads
' over 1 character but under 100
' and left aligned only
' and skips lines that already have comments
' and does not add comments to text in tables
Dim p As Integer
Dim para As Range

For p = 1 To ActiveDocument.Paragraphs.Count
ActiveDocument.Paragraphs(p).Range.Select
Set para = ActiveDocument.Paragraphs(1).Range
If (Not Selection.Range.Information(wdWithInTable)) And _
Selection.Font.Bold = True And _
Selection.Characters.Count < 100 And _
Selection.Characters.Count > 1 And _
Selection.ParagraphFormat.Alignment = wdAlignParagraphLeft And _
Selection.Comments.Count = 0 Then
Selection.Comments.Add Range:=Selection.Range, Text:="F"
End If

Next p
End Sub

 

[Helmut Weber]

Hi Antigone,

this is certainly not yet all you need.
It is just an example, how to set a temporary range
to the text from
Doc start to start of table(1)
to text between tables
to text from
the last table's end to the doc's end.

With that you can process the temporary range
and would never touch a table at all.

Besides that, I doubt whether all the "and"s are the fastest solution.
But, in fact, I don't know.

Sub test0005()
Dim l As Long ' just a counter
Dim rTmp As Range ' a temporary range
Set rTmp = ActiveDocument.Range
rTmp.End = ActiveDocument.Tables(1).Range.Start
rTmp.Font.Color = wdColorRed

For l = 2 To ActiveDocument.Tables.Count - 1
rTmp.Start = ActiveDocument.Tables(l).Range.End
rTmp.End = ActiveDocument.Tables(l + 1).Range.Start
rTmp.Select ' for testing only
rTmp.Font.Color = wdColorRed
Next

rTmp.Start = ActiveDocument.Tables(l).Range.End
rTmp.End = ActiveDocument.Range.End
rTmp.Font.Color = wdColorRed
End Sub

 

[Antigone]

Helmut,
Nice to meet you and thanks for your response.
I will try to incorporate the logic you presented tomorrow, as I would love
it if it didn't touch the tables at all, and I am trying to shave as much run-
time off as possible.

I incorporated the calculate run time from a previous post by Jonathan West -
BenchmarkParagraphCollection.
My original code took 761 seconds to process through a 100 page file with
tables throughout.

I was able to finally come up with something that does work.
This revised code I came up with after my original post took 127 seconds to
process:
10 minutes saved 8 )

----------------------------------------------

Sub findboldheadsFv34()
Dim rngWholeDoc As Range
Dim myRange As Range
Dim oPar As Paragraph
Dim p, c, t As Long
t = 1
Dim dStart As Date
Dim dEnd As Date
' 127 second on 5-8-06.doc test file
dStart = Now()

Set rngWholeDoc = ActiveDocument.StoryRanges(wdMainTextStory)
For p = 1 To rngWholeDoc.Paragraphs.Count
ActiveDocument.Paragraphs(p).Range.Select
Set myRange = rngWholeDoc.Paragraphs(1).Range
If Selection.Characters(1).Information(wdWithInTable) = False Then
If Selection.Font.Bold = True And _
Selection.Characters.Count < 120 And _
Selection.Characters.Count > 1 And _
Selection.ParagraphFormat.Alignment = wdAlignParagraphLeft And _
Selection.Comments.Count = 0 Then
Selection.Comments.Add Range:=Selection.Range, Text:="F"
p = p + 1
End If
ElseIf Selection.Characters(1).Information(wdWithInTable) = True Then
ActiveDocument.Tables(t).Select
Selection.Collapse wdCollapseEnd
t = t + 1
c = ActiveDocument.Range(0, Selection.Paragraphs(1).Range.End).Paragraphs.
Count
p = c
Else
Exit For
End If
Next p

dEnd = Now()
Debug.Print "For-Next: " & DateDiff("s", dStart, dEnd) & " Seconds"

End Sub

 

[Antigone via OfficeKB.com]

Anyone see's anything in the last set of code that they think is redundant.
I'm trying to make it run as fast as possible.

 

[Helmut Weber]

Hi Antigone,

at least _I_ am quite satisfied with this one,
which need 4.5 seconds on an pretty fast maschine.
Number of pages = 94
Number of tables = 228
Number of commets = 116

Minimizing the whole application may gain another half second.
And I still think, the code could be improved.

' ----------------------------------------------------------------------
Option Explicit
Public Declare Function GetTickCount Lib "kernel32" () As Long

Sub test0005()
Dim t As Long ' time
Dim l As Long ' just a counter
Application.ScreenUpdating = False
t = GetTickCount
Dim oPrg As Paragraph
Dim rTmp As Range ' a temporary range
Set rTmp = ActiveDocument.Range
' before first atbe
With rTmp
.End = ActiveDocument.Tables(1).Range.Start
For Each oPrg In .Paragraphs
CheckPrg oPrg
Next
End With
' between tables
For l = 1 To ActiveDocument.Tables.Count - 1
With rTmp
.Start = ActiveDocument.Tables(l).Range.End
.End = ActiveDocument.Tables(l + 1).Range.Start
For Each oPrg In .Paragraphs
CheckPrg oPrg
Next
End With
Next
' after last table
With rTmp
.Start = ActiveDocument.Tables(l).Range.End
.End = ActiveDocument.Range.End
For Each oPrg In .Paragraphs
CheckPrg oPrg
Next
End With
MsgBox GetTickCount - t
Application.ScreenUpdating = True
End Sub

Sub CheckPrg(rPrg As Paragraph)
With rPrg
rPrg.Range.Select
If .Range.Font.Bold <> True Then Exit Sub
If .Range.Characters.Count > 119 Then Exit Sub
If .Range.Characters.Count > 119 Then Exit Sub
If .Range.Comments.Count > 0 Then Exit Sub
If .Range.Comments.Count > 0 Then Exit Sub
If .Alignment <> wdAlignParagraphLeft Then Exit Sub
.Range.Comments.Add Range:=rPrg.Range, Text:="F"
End With
End Sub

Have a close look at the logic in "Sub CheckPrg".
It is assumed, that there are at least two tables.
You have to check that yourself.

HTH

 

[Helmut Weber]

....

one typo:

' before first atbe '?
' before first table '!

One redundant line, put in for testing.

Sub CheckPrg(rPrg As Paragraph)
With rPrg
rPrg.Range.Select <<< for testing only
....
End Sub

HTH

Helmut Weber, MVP

 

[Helmut Weber]

....
still one more, it's not my day

Sub CheckPrg(rPrg As Paragraph)
With rPrg
' rPrg.Range.Select ' for testing only
If .Range.Font.Bold <> True Then Exit Sub
If .Range.Characters.Count > 119 Then Exit Sub
If .Range.Characters.Count = 1 Then Exit Sub
If .Range.Comments.Count > 0 Then Exit Sub
If .Alignment <> wdAlignParagraphLeft Then Exit Sub
.Range.Comments.Add Range:=rPrg.Range, Text:="F"
End With
End Sub

Helmut Weber, MVP