Loops become very slow

Discussion in 'Word VBA Beginners' started by robin.moss@logica.com, Mar 11, 2014.

  1. Guest


    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 _

    ' 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

    ' 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
    End If
    End If
    End If

    Application.ScreenUpdating = True
    End Sub
    , Mar 11, 2014
    1. Advertisements

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 (here). After that, you can post your question and our members will help you out.