Loops become very slow

R

robin.moss

Hi,

I've copied in (below) a macro i've been working on. The gist of what it does it loops over all the tables in the documents and checks to see if the following paragraph starts with "Table: ", if it does it converts it into a caption.

The reason i need to do this is the documents are auto generated and i've not been able to get the auto generation to do captions for me.

The Macro works, and worked reasonable well until i needed to run it on a document that is ~1,200 pages and have just shy of 900 tables.

I've added a few debugging lines in (as you'll see), the main one is checking how long it takes to run every 100 tables, this gets interesting as 0-100 are done in 3 seconds, 101-200 as done in 2 minutes, 201+ just crashes (or is extremely slow)

Sorry for lack of formatting of the code, not sure how to do it

Sub tableCaptions()
Application.ScreenUpdating = False

Dim cTable As Table
Dim curPos As Integer
Dim curText As String
Dim rng As Range


Set RegExpFind = CreateObject("VBScript.RegExp")
RegExpFind.Global = False ' Find only the first match when using execute
RegExpFind.IgnoreCase = True

Dim count As Long

count = 0
Debug.Print ActiveDocument.Tables.count
For Each cTable In ActiveDocument.Tables

If (count Mod 100) = 0 Then
Debug.Print now
MsgBox prompt:=count & " tables done", Title:="Note"
Debug.Print now
End If

' get the paragraph after the table
Set rng = cTable.Range
rng.Move Unit:=wdParagraph, count:=1
rng.Expand Unit:=wdParagraph

RegExpFind.pattern = "^[T|t]able:.*$"
If RegExpFind.test(rng.text) Then
' Get the paragraph, remove the table and keep the rest for the caption
curText = rng.text
curText = Replace(curText, "table: ", "")
curText = Replace(curText, "Table: ", "")
rng.text = ""

' Inser the caption
rng.InsertCaption _
Label:=wdCaptionTable

' Insert the free text
rng.text = ": " + curText

' Make sure the table stays with its caption
cTable.Range.ParagraphFormat.KeepWithNext = True
End If
count = count + 1
ActiveDocument.UndoClear
Next

'
' Note: Haven't gotten this far yet and the below is new code (hopefully
' faster, so there may be bugs in it still)
'

RegExpFind.pattern = "^[T|t]able:.*$"

Dim searchRng As Range

' Use regex to find all the 'Figure: xyz' captions
Set myMatches = RegExpFind.execute(ActiveDocument.Range.text)
For Each myMatch In myMatches

Set searchRng = ActiveDocument.Content
' Use words find function to get the range.
If searchRng.Find.execute(FindText:=myMatch, Forward:=True, MatchWholeWord:=True) Then
' Select the range and extend the to the end of the paragraph
Set rng = searchRng

rng.MoveStart Unit:=wdParagraph, count:=-1
rng.MoveEnd Unit:=wdParagraph

If Not rng.Style Is Nothing Then
If rng.Style = "Body Text" Or rng.Style = "Normal" Then
' If the style is body text (excludes captions) delete it
rng.Delete
End If
End If
End If
Next

Application.ScreenUpdating = True
End Sub
 

Ask a Question

Want to reply to this thread or ask your own question?

You'll need to choose a username for the site, which only take a couple of moments. After that, you can post your question and our members will help you out.

Ask a Question

Top