Word VBA Code to Automate Table Captioning I have a Word VBA script that auto-generates a table caption based on user input &amp; a previous heading. Its purpose is to speed up editing &amp; 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 &amp; 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") &amp; " " &amp; 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 &lt;&gt; strHeadLevel

    If ActiveDocument.Range(0, rngPrev.Paragraphs(1).Range.End).Paragraphs.Count &gt; 1 Then

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

        'MsgBox ("Heading not found")
        Exit Do

    End If

Loop

If rngPrev.Style = strHeadLevel Then
    FindHeading = rngPrev.Paragraphs(1).Range.Text
Else
    FindHeading = "No heading found"
End If

End Function
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") &amp; " " &amp; 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:


Get user input number
Convert number to the appropriate table style
Find the relevant table heading and clean the text a bit
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 &gt;= 1 And intCheck &lt;= 3 Then
            isValidInput = True
        End If
    End If

    If isValidInput Then
        TypenumFromUser= intCheck
    Else
        GoTo BadUserInput
    End If

CleanExit:
    Exit Function

BadUserInput:
    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") &amp; " " &amp; 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
            GoTo BadInput

    End Select

CleanExit:
    TypestringFromTypenum = typeString
    Exit Function

BadInput:
    MsgBox "Unexpected Input Error. See Debug."
    Debug.Print "The following should be 1, 2 or 3: " &amp; 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") &amp; " " &amp; 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 = heading
    cleanString = Replace(cleanString, vbCr, "")
    cleanString = Replace(cleanString, "-", "")

    Dim hasMultiSpaces As Boolean
    hasMultiSpaces = (InStr(cleanString, "  ") &lt;&gt; 0)
    Do Until hasMultiSpaces = False
        cleanString = Replace(cleanString, "  ", " ")
        hasMultiSpaces = (InStr(cleanString, "  ") &lt;&gt; 0)
    Loop

    CleanTableHeading = cleanString

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
    tableHeading = FindHeading("Heading 3") &amp; " " &amp; tableTypeString

    Dim cleanHeading As String
    cleanHeading = CleanTableHeading(tableHeading)

    GenerateCaption cleanHeading, "Table"

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]: " &amp; NOW() throughout your code. Like so:

Public Sub TestTableCaption()

    Debug.Print "ExecutionStart: " &amp; Now()

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

    Dim tableHeading As String
    tableHeading = FindHeading("Heading 3") &amp; " " &amp; tableTypeString
    Debug.Print "Found Table Heading: " &amp; Now()

    Dim cleanHeading As String
    cleanHeading = CleanTableHeading(tableHeading)
    Debug.Print "Cleaned Table Heading: " &amp; Now()

    GenerateCaption cleanHeading, "Table"
    Debug.Print "Generated Caption: " &amp; 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