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
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