# Word VBA Code to Automate Table Captioning

I have a Word VBA script that auto-generates a table caption based on user input & a previous heading. Its purpose is to speed up editing & formatting of massive software documents (like the 1000+ page test procedure I'm currently reviewing). At this point, it's slightly quicker than scrolling back up, copying the heading manually, creating a caption, and pasting it in, but it lags a little. So, I'm looking for advice on optimizing & speeding it up.

I should note that this is only for my use (which might be obvious by the less than serious user prompts) and that I'm a tech writer who dabbles in VBA, rather than someone with a programming background.

Here's the script itself:

Sub TestTableCaption()

Dim strCaption As String
Dim intTableType As Integer
Dim strTableType As String

strTableType = InputBox("Enter 1 for Test Requirements Matrix, 2 for Test Status, or 3 for Test Steps")
intTableType = Val(strTableType)

Select Case intTableType

Case 1
strTableType = "Test Requirements Matrix"

Case 2
strTableType = "Test Status"
Case 3
strTableType = "Test Steps"
Case Else
strTableType = ""
MsgBox ("Entry needs to be 1, 2, or 3. Learn to follow directions, then try again.")
Exit Sub

End Select

strCaption = FindHeading("Heading 3") & " " & strTableType
strCaption = Replace(strCaption, vbCr, "")

strCaption = Replace(strCaption, Chr(150), "")
strCaption = Replace(strCaption, "  ", " ")
'In theory, Gets rid of dash from title. Doesn't actually work.

'MsgBox (strCaption)
Call GenerateCaption(strCaption, "Table")
End Sub


And here's the FindHeading function:

Function FindHeading(strHeadLevel As String) As String
'Gets the heading level as an input and finds the closest heading of that level before the selection.

Dim rngSelection As Range
'the initial selection

Dim rngPrev As Range
'The current paragraph to be evaluated.

Set rngSelection = Selection.Range

Set rngPrev = rngSelection.Previous(wdParagraph, 1)

'MsgBox (rngPrev.Text)

Do While rngPrev.Style <> strHeadLevel

If ActiveDocument.Range(0, rngPrev.Paragraphs(1).Range.End).Paragraphs.Count > 1 Then

Set rngPrev = rngPrev.Previous(wdParagraph, 1)
'MsgBox ("rngPrev Style =  " & rngPrev.Style & vbCr & "Text = " & rngPrev.Text)
Else

Exit Do

End If

Loop

If rngPrev.Style = strHeadLevel Then
Else
End If

End Function

• Not much to the code that I can see so I'm not sure what can be optimized. How much time does it take for 1000 pages? It's possible you could speed it up slightly by use With to refer to rngPrev, and by turning Application.ScreenUpdating off and on at start and end of processing, but I don't think the improvements would be huge. It doesn't sound like a loop would apply here either - as you're processing each table individually, correct? – dbmitch Jul 13 '16 at 17:01
• I just timed it, and it took all of 40 seconds, including updating fields and repaginating. (I think there have been times it's taken longer.) You're right about the loop. Each table is processed individually. I might be able to expand on it to tell from table content which caption a table would get, and then just run the whole thing once. – Kelly Tessena Keck Jul 14 '16 at 11:30

## Clean everything up

Code should be written for other people (including future you) to read and understand. A key aspect of this is using consistent rules and conventions for laying out your code.

Indent logic levels, put comments on the same line as the thing being commented (where feasible), use whitespace liberally and consistently.

Same code, much easier to "see", at a glance, what's going on:

Public Sub TestTableCaption()

Dim strTableType As String
strTableType = InputBox("Enter 1 for Test Requirements Matrix, 2 for Test Status, or 3 for Test Steps")

Dim intTableType As Integer
intTableType = Val(strTableType)
Select Case intTableType

Case 1
strTableType = "Test Requirements Matrix"
Case 2
strTableType = "Test Status"
Case 3
strTableType = "Test Steps"
Case Else
strTableType = ""
MsgBox ("Entry needs to be 1, 2, or 3. Learn to follow directions, then try again.")
Exit Sub

End Select

strCaption = FindHeading("Heading 3") & " " & strTableType
strCaption = Replace(strCaption, vbCr, "")
strCaption = Replace(strCaption, Chr(150), "")
strCaption = Replace(strCaption, "  ", " ")
'In theory, Gets rid of dash from title. Doesn't actually work.

'MsgBox (strCaption)
Call GenerateCaption(strCaption, "Table")

End Sub


And now we can immediately see that your sub has 4 distinct sub-sections:

1. Get user input number
2. Convert number to the appropriate table style
3. Find the relevant table heading and clean the text a bit
4. Call GenerateCaption with the (now cleaned) caption text.

This leads us to the next key idea:

## Refactor Mercilessly

Refactoring is the process of taking some set of operations, and abstracting them into their own Sub/Function. This makes your code cleaner, easier to follow, easier to modify and more re-usable.

Let's take this a step at a time.

Step 1: Get the user input string.

What are our requirements? The user needs to indicate which of 3 table types to change by inputting a number from 1 to 3.

First, a Descriptive, Unambiguous, name:

Public Function TypenumFromUser() As Long


Second, get input.

    Dim userInput As String
userInput = InputBox("Enter 1 for Test Requirements Matrix, 2 for Test Status, or 3 for Test Steps")


Third, validate Input. Input must be a number. And it must be 1, 2 or 3. If the input is invalid, let's prompt the user to try again.

Public Function TypenumFromUser() As Long
'/ User must input a table type as a number
'/ Current options are 1, 2 or 3
'/ If the input is invalid, prompt the user to try again

GetNewInput:
Dim userInput As String
userInput = InputBox("Enter 1 for Test Requirements Matrix, 2 for Test Status, or 3 for Test Steps")

Dim intCheck As Long
On Error GoTo BadUserInput
intCheck = CLng(userInput)
On Error GoTo 0

Dim isValidInput As Boolean
isValidInput = False
If IsWholeNumber(intCheck) Then
If intCheck >= 1 And intCheck <= 3 Then
isValidInput = True
End If
End If

If isValidInput Then
TypenumFromUser= intCheck
Else
End If

CleanExit:
Exit Function

MsgBox "Input must be a whole number from 1 to 3. Please try again."
GoTo GetNewInput

End Function

Public Function IsWholeNumber(ByVal checkNum As Variant) As Boolean
'/ First check that input is a number.
'/ Then round to the nearest whole number.
'/ If the rounded number is the original number, then it is a whole number

IsWholeNumber = False
If IsNumeric(checkNum) And (Math.Round(checkNum, 0) = checkNum) Then
IsWholeNumber = True
End If

End Function


Sure, it's a bit verbose, but now you never need to touch this function again. And if your inputs change, you know exactly where to go to change things.

You've also now got an IsWholeNumber function which you can use in other projects down the line. You should build these utility function up over time and before long, you'l have a whole module full of useful little functions that you can import into any new project.

Now, your sub looks like this:

Public Sub TestTableCaption()

Dim intTableType As String
intTableType = TypenumFromUser
Select Case intTableType

Case 1
strTableType = "Test Requirements Matrix"
Case 2
strTableType = "Test Status"
Case 3
strTableType = "Test Steps"
Case Else
strTableType = ""
MsgBox ("Entry needs to be 1, 2, or 3. Learn to follow directions, then try again.")
Exit Sub

End Select

strCaption = FindHeading("Heading 3") & " " & strTableType
strCaption = Replace(strCaption, vbCr, "")
strCaption = Replace(strCaption, Chr(150), "")
strCaption = Replace(strCaption, "  ", " ")
'In theory, Gets rid of dash from title. Doesn't actually work.

'MsgBox (strCaption)
Call GenerateCaption(strCaption, "Table")

End Sub


Step 2: Convert input to a table typestring

This is also begging to be refactored into a function. TypestringFromTypenum.

Public Function TypestringFromTypenum(ByVal typeNum As Long) As String

Dim typeString As String

Select Case typeNum

Case 1
typeString = "Test Requirements Matrix"
Case 2
typeString = "Test Status"
Case 3
typeString = "Test Steps"
Case Else

End Select

CleanExit:
TypestringFromTypenum = typeString
Exit Function

MsgBox "Unexpected Input Error. See Debug."
Debug.Print "The following should be 1, 2 or 3: " & CStr(typeNum)
Resume CleanExit

End Function


Now, if you have to add another input, all you have to do is add 2 lines here, modify the input validation, and you don't even have to touch the rest of your code.

And now, we should roll this together with TypenumFromUser. Like so:

Public Function TypestringFromUser() As String

Dim typeNum As Long
typeNum = TypenumFromUser

Dim typeString As String
typeString = TypestringFromTypenum

TypestringFromUser = typeString

End Function


With TypenumFromUser and TypestringFromTypenum as above.

Now your sub looks like this:

Public Sub TestTableCaption()

Dim tableTypeString As String
tableTypeString = TypestringFromUser

strCaption = FindHeading("Heading 3") & " " & tableTypeString
strCaption = Replace(strCaption, vbCr, "")
strCaption = Replace(strCaption, Chr(150), "")
strCaption = Replace(strCaption, "  ", " ")
'In theory, Gets rid of dash from title. Doesn't actually work.

'MsgBox (strCaption)
Call GenerateCaption(strCaption, "Table")

End Sub


With the rest nicely abstracted away.

Step 3: I'm not very familiar with the Word Object Model, so I'm going to leave FindHeading alone. Though I would rename it to GetTableHeading.

Step 4: Clean heading Text.

This absolutely needs to be its' own function. CleanTableHeading

Public Function CleanTableHeading(ByVal heading As String) As String
'/ Remove carriage returns
'/ Remove dashes
'/ Reduce multi-spaces to single spaces

Dim cleanString As String

cleanString = Replace(cleanString, vbCr, "")
cleanString = Replace(cleanString, "-", "")

Dim hasMultiSpaces As Boolean
hasMultiSpaces = (InStr(cleanString, "  ") <> 0)
Do Until hasMultiSpaces = False
cleanString = Replace(cleanString, "  ", " ")
hasMultiSpaces = (InStr(cleanString, "  ") <> 0)
Loop

End Function


You ever need to add another paramater to your string cleaning? Just come straight here, change it once and you're done.

## Your main sub now looks like this:

Public Sub TestTableCaption()

Dim tableTypeString As String
tableTypeString = TypestringFromUser

Dim tableHeading As String

Dim cleanHeading As String

End Sub


Much easier to work with.

## Performance

Rule #1 of performance optimisation: Benchmarking.

I guarantee you that 95% of your operations run in a fraction of a second. There will be one sub/function/loop somewhere which is taking up the other 40 seconds. In order to fix it, you must first find it.

Simple Option: Just Debug.Print "[Position]: " & NOW() throughout your code. Like so:

Public Sub TestTableCaption()

Debug.Print "ExecutionStart: " & Now()

Dim tableTypeString As String
tableTypeString = TypestringFromUser
Debug.Print "Got TypeString From User: " & Now()

Dim tableHeading As String
Debug.Print "Found Table Heading: " & Now()

Dim cleanHeading As String
Debug.Print "Cleaned Table Heading: " & Now()

Debug.Print "Generated Caption: " & Now()

End Sub


Run that, and you'll get a nice printout in the immediate window of how long each sub/function took to execute.

Once you know where the problem code is, post that as its' own separate performance question here or on Stack Overflow. (I recommend here).

That aside, some very basic VBA performance improvements:

Public Sub MainSub()

Application.ScreenUpdating = False
Application.EnableEvents = False
Application.StatusBar = False

...

Code

Code

Code

...

Application.ScreenUpdating = True
Application.EnableEvents = True
Application.StatusBar = True

End Sub

• After using Debug.Print to get times for each function, it looks like finding the heading is the big time suck (relatively speaking---16 seconds might be totally reasonable to loop back through the document and find the nearest para of a specific style). ExecutionStart: 7/14/2016 11:27:04 GotTypeStringFromUser: 7/14/2016 11:27:09 FoundHeading: 7/14/2016 11:27:25 CleanedHeading: 7/14/2016 11:27:25 GeneratedCaption: 7/14/2016 11:27:36 – Kelly Tessena Keck Jul 14 '16 at 15:30
• @KellyTessenaKeck Well there you go. Take your FindHeading Function. Stick it in a specific question and ask for a performance tuneup. – Kaz Jul 14 '16 at 16:03