Some Useful Macro Examples

This worked fine, until fellow MVP Paul Edstein, who uses the pseudonym Macropod in the forums, baited me to produce a version which gave the user the opportunity to add a CHARFORMAT switch as an alternative to the MERGEFORMAT switch. The result was the following.

Inserting a field from the Insert > Field menu option (Insert > Quick Parts > Field in Word 2007/2010) opens the dialog with the check box unchecked, using the same method as above, but if you check the box, you are presented with a message box which offers the opportunity to choose the type of formatting switch, then adds the appropriate switch to the field.

The result is that the field may be inserted with either switch as appropriate e.g.

{ CREATEDATE \@ "dddd, dd MMMM yyyy" \* CHARFORMAT }

by selecting YES

{ CREATEDATE \@ "dddd, dd MMMM yyyy" \* MERGEFORMAT }

by selecting No

or none if the Insert Field Dialog box is left unchecked.

Sub InsertField()
Dim oRng As Range
Dim i As Variant
Dim sSwitch As String
Dim strChoice As String
SendKeys "{Tab}{Tab} +{Tab}+{Tab}"
Dialogs(wdDialogInsertField).Show

On Error Goto Finish 'User has cancelled
Selection.MoveLeft Unit:=wdCharacter, Count:=1, Extend:=wdExtend
Set oRng = Selection.Range
For i = 1 To oRng.Fields.Count
    With oRng.Fields(i)
        If InStr(1, .Code, "MERGEFORMAT") <> 0 Then
             sSwitch = MsgBox("Use charformat in place of the mergeformat switch?", _
             vbYesNo, _
             "Insert Field")
             If sSwitch = vbYes Then
                  .Code.Text = Replace(.Code.Text, _
                  "MERGEFORMAT", _
                  "CHARFORMAT")
             End If
        End If
    .Update
    End With
Next i
Selection.MoveRight Unit:=wdCharacter, Count:=1

I am informed, by the aforementioned Paul Edstein, that the SendKeys approach will not work under the Windows Vista operating system, returning error code 70: "Permission denied" - so that's another reason why I will be keeping Windows XP for the foreseeable future.

Sub InsertField()
Dim oRng As Range
Dim i As Variant
Dim sSwitch As String
Dim strChoice As String
Dialogs(wdDialogInsertField).Show

On Error Goto Finish 'User has cancelled
Selection.MoveLeft Unit:=wdCharacter, Count:=1, Extend:=wdExtend
Set oRng = Selection.Range
For i = 1 To oRng.Fields.Count
    With oRng.Fields(i)
        If InStr(1, .Code, "MERGEFORMAT") <> 0 Then
             sSwitch = MsgBox("Use charformat in place of the mergeformat switch?", _
             vbYesNo, _
             "Insert Field")
             If sSwitch = vbYes Then
                  .Code.Text = Replace(.Code.Text, _
                  "MERGEFORMAT", _
                  "CHARFORMAT")
             End If

             If sSwitch = vbNo Then
                  sSwitch = MsgBox("Remove switch?", _
                  vbYesNo, _
                  "Insert Field")
                  If sSwitch = vbYes Then
                       .Code.Text = Replace(.Code.Text, _
                       " \* MERGEFORMAT ", _
                       "")
                  End If
             End If
        End If
    .Update
    End With
Next i
Selection.MoveRight Unit:=wdCharacter, Count:=1

There is a page on this site dedicated to numbering documents but on a number of occasions I have been asked for a variation of this to place an incrementing number at a bookmarked location in a series of documents. The example used here was created to print a batch of numbered receipts, and includes a second macro to reset the stored start number.

Sub SendDocumentAsAttachment()

'This macro requires the Outlook Object library to be checked

You receive the "Opening this will run the following SQL command" message when you open a Word mail merge main document that is linked to a data source - http://support.microsoft.com/?kbid=825765

Sub ToggleSQLSecurity()
Dim WSHShell, RegKey, rKeyWord, wVer
Set WSHShell = CreateObject("WScript.Shell")
wVer = Application.Version
If wVer < 10 Then 'The security issue relates to

'Word versions greater than 10.0 (Word 2002)
     MsgBox "This macro is for Word 2002 and later!", vbOKOnly, "Wrong Word Version"
     Exit Sub
End If
Start:
RegKey = "HKEY_CURRENT_USER\Software\Microsoft\Office\" & wVer & "\Word\Options\"
On Error Resume Next 'The registry key does not exist
rKeyWord = WSHShell.RegRead(RegKey & "SQLSecurityCheck")
If rKeyWord = "" Then
     WSHShell.regwrite RegKey & "SQLSecurityCheck", 1, "REG_DWORD" 'set it at zero
     GoTo Start: 'and read it again
End If
If rKeyWord = 1 Then
     WSHShell.regwrite RegKey & "SQLSecurityCheck", 0, "REG_DWORD"

     MsgBox "SQL Security checking is switched off", vbInformation, "SQL Check"

Else
     WSHShell.regwrite RegKey & "SQLSecurityCheck", 1, "REG_DWORD"

Word has the ability to set a block of text in title case, i.e. each of the words formatted so that its first letter is capitalized, thus:

A Tale Of Two Cities but formatting styles often dictate that articles, prepositions, and conjunctions should be in lower case, thus: A Tale of Two Cities.

Word has no built-in function to perform this type of formatting, but it can be achieved with a macro. The following sets the selected text in Word's title case and then sets all the words in the first array:

vFindText = Array("A", "An", "And", "As", "At", "But", "By", "For", _
"If", "In", "Of", "On", "Or", "The", "To", "With")

to their lower case equivalents with a corresponding array

vReplText = Array("a", "an", "and", "as", "at", "but", "by", "for", _
"if", "in", "of", "on", "or", "the", "to", "with")

The list of corrections can be expanded as required by simply adding the word in its alternative forms to both lists.

Sub ExtractAcronyms()

Dim rText As Range

Dim SDoc As Document

Dim TDoc As Document

Set SDoc = ActiveDocument

Set TDoc = Documents.Add

SDoc.Activate

With Selection

    .HomeKey wdStory

    With .Find

        .ClearFormatting

        .Replacement.ClearFormatting

        .Replacement.Text = ""

        Do While .Execute(findText:="[A-Z.]{2,}", _

            MatchWildcards:=True, _

            Wrap:=wdFindStop, Forward:=True) = True

            Set rText = Selection.Range

            TDoc.Range.InsertAfter rText & vbCr

            rText.Collapse wdCollapseEnd

        Loop

    End With

End With

With TDoc
     .Range.Sort ExcludeHeader:=False, _
        FieldNumber:="Paragraphs", _
        SortFieldType:=wdSortFieldAlphanumeric, _
        SortOrder:=wdSortOrderAscending
     .Paragraphs(1).Range.Delete
     .Activate
End With

Word's replace function is capable of applying formatting to found strings, but only the whole of a found string. Sometimes it is desirable to format only part of the string e.g. you may search for the chemical symbol for water H2O in order to format the 2 as subscript. The replace function cannot do that. With this example the simplest solution is to copy the correctly formatted version to the clipboard and replace the find string H2O with the clipboard contents H₂O i.e. put ^c  in the replace with box.

OR

Sub Subscript2_in_H2O()

Dim rText As Range

With Selection

    .HomeKey wdStory

    With .Find

        .ClearFormatting

        .Replacement.ClearFormatting

        Do While .Execute(findText:="H2O", _

            MatchWildcards:=False, _

            Wrap:=wdFindStop, _

            Forward:=True) = True

            Set rText = Selection.Range 'The found text

            With rText 'Do what you want with the found text

                'move the start position of the found text one character right

                .MoveStart Unit:=wdCharacter, Count:=1

                'move the end position of the found text one character to the left

                .MoveEnd Unit:=wdCharacter, Count:=-1

                'the text string is now one character long i.e. the "2"

                .Font.Subscript = True 'apply subscript to the remaining text string

            End With

        Loop 'and look for the next match

    End With

End With

End Sub

or even simpler

Sub Subscript2_in_H2ORev1()
With Selection
    .HomeKey wdStory
        With .Find
            .ClearFormatting
            .Replacement.ClearFormatting
            Do While .Execute(findText:="H2O", _

                     MatchWildcards:=False, _

                     Wrap:=wdFindStop, _

                     Forward:=True) = True
               'Do what you want with the found text (Selection.Range)

               'In this case format the second character as subscripted
                Selection.Range.Characters(2).Font.Subscript = True
            Loop 'and look for the next match
        End With
End With
End Sub

Extending the above procedure, you may wish to format a number of similar items - eg chemical formulae. The following version defines the list of items as variants. Note that the subscripted numbers are located in different parts of the text string. The macro loops through the list searching for each variant throughout the document in turn. It then uses Case statements to process the range for each variant to achieve the results shown in red (when pasted to the vba editor the red colour will change to green and the format of the red coloured items will be lost).

Sub FormatChemicalFormulae()
Dim rText As Range
Dim vFindText(4) As Variant 'match the number in the brackets

'to the last number in the list below
Dim i As Long

vFindText(0) = "H2O"
vFindText(1) = "CO2"
vFindText(2) = "H2SO4"
vFindText(3) = "SO42-"
vFindText(4) = "[CO(NH3)6]3+"

'add more numbers as required

'increment the number 'n' in the brackets vFindText(n)

In a recent Word forum question, a user wanted to automatically provide the function to add a row to a table in a protected form and to fill the new row with form fields to match those in the previous row, but with new field bookmark names and a calculation in the final cell to add the other fields in the row. The user had done most of the work, which I have borrowed for this example, but was having problems with the calculation.

Sub addrow()
'Works with a seven column table
Dim oTable As Table
Dim Response As String
Dim CurRow As Long
Dim i As Long
Dim fCount As Long

Dim sPassword as String

Set oTable = ActiveDocument.Tables(1)

sPassword = "" 'Define the password used to protect the form (if any)
Response = MsgBox("Add new row?", vbQuestion + vbYesNo)
If Response = vbYes Then
     ActiveDocument.Unprotect Password:="sPassword" 'Unprotect document
     Selection.InsertRowsBelow 1 'Add a row to the bottom of the table
     Selection.Collapse (wdCollapseStart) 'Put the cursor in the first cell of the new row
     CurRow = Selection.Information(wdStartOfRangeRowNumber) 'Read the number of the new row

     For i = 1 To oTable.Columns.Count
          oTable.Cell(CurRow, i).Select 'Select the next cell for processing
          Selection.FormFields.Add Range:=Selection.Range, _
          Type:=wdFieldFormTextInput 'And add a form field
          fCount = ActiveDocument.Range.FormFields.Count
          With ActiveDocument.FormFields(fCount)
               .Name = "col" & i & "row" & CurRow 'Add a unique bookmark name
               .Enabled = True 'Enable the field for user entry
               .CalculateOnExit = True 'set the calculate on exit check box
               If i = 6 Then .ExitMacro = "addrow" 'add this macro to the cell in column 6
               If i = 7 Then 'add a calculation to add the field results in cols 1 to 6
                    .Enabled = False
                    .TextInput.EditType Type:=wdCalculationText, _
                    Default:="=Col1Row" & CurRow _
                    & " + Col2Row" & CurRow _
                    & " + Col3Row" & CurRow _
                    & " + Col4Row" & CurRow _
                    & " + Col5Row" & CurRow _
                    & " + Col6Row" & CurRow, _
                    Format:=""
               End If
          End With
     Next i
 

The previous method created the new row in the table and added the fields to the cells. The following takes an alternative approach and copies the last row of the table, complete with its fields and associated macros, and pastes it at the end of the table. It then removes the on exit macro from what was previously the last row, so that there can be no false triggering of the macro if a user goes back to amend a field's content in the last column of a previous row.

The macro makes use of the wdDialogFormFieldOptions dialog, which has the following arguments: Entry, Exit, Name, Enable, TextType, TextWidth, TextDefault, TextFormat, CheckSize, CheckWidth, CheckDefault, Type, OwnHelp, HelpText, OwnStat, StatText, Calculate, to modify the field properties.

Sub AddRow()
'Run on exit from the last form field in
'the last row of the table
Dim oTable As Table
Dim oRng As Range
Dim oCell As Range
Dim oLastCell As Range
Dim sResult As String
Dim iRow As Integer
Dim iCol As Integer
Dim CurRow As Integer
Dim i As Long

Dim sPassword as String

Private mstrFF As String
Sub ColTable1Row1()
Dim oFld As FormFields
Dim i As Long
Dim sCount As Integer
Dim sRow As Integer
Dim bProtected As Boolean

Dim sPassword as String

sPassword = "" 'Insert the password (if any), used to protect the form between the quotes
With GetCurrentFF 'Establish which dropdown field is current
     mstrFF = GetCurrentFF.Name
End With
Set oFld = ActiveDocument.FormFields
sCount = oFld(mstrFF).Result 'Get the dropdown field value
sRow = Right(mstrFF, 1) 'Get the number at the end of the bookmark name
 

'Check if the document is protected and if so unprotect it

If ActiveDocument.ProtectionType <> wdNoProtection Then
     bProtected = True
     ActiveDocument.Unprotect Password:=sPassword
End If
 

For i = 2 To 11 'Select each column of the active row in turn and colour the cell white
     ActiveDocument.Tables(1).Rows(sRow).Cells(i).Shading.BackgroundPatternColor = wdColorWhite
Next i

In the following example a user wished to provide a variable number of fields and associated formatted text dependant on a figure input into a form field, as in the following illustration. For the purpose of the exercise, the control field 'Mortgages' was set as a number field, the following macro was run on exit from that field, and the section to be repeated was bookmarked with the name 'bMortgage'.

Note that some of the text is underlined, some is emboldened and some both underlined and emboldened. There are eight fields in the selection, each of which will be provided with a new bookmark name. The bookmark names of the fields in that marked section will be replaced by the macro, with the names "MortTextn" where 'i' is a numeric digit from 1 to 8. Subsequent iterations will be numbered from 8 - 16, 16 -24 etc.

Private mstrFF As String
Sub EmphasiseCheckedBox()
Dim oFld As FormFields
Dim sCount As Integer
Dim bProtected As Boolean
Dim sPassword As String

sPassword = "" 'Insert the password (if any), used to protect the form between the quotes
With GetCurrentFF 'Establish field is current
     mstrFF = GetCurrentFF.name
End With

Set oFld = ActiveDocument.FormFields
sCount = oFld(mstrFF).CheckBox.Value 'Get the Checkbox field value
'Check if the document is protected and if so unprotect it

If ActiveDocument.ProtectionType <> wdNoProtection Then
     bProtected = True
     ActiveDocument.Unprotect Password:=sPassword
End If

With oFld(mstrFF).Range
     If sCount = True Then
          .Font.Color = wdColorRed 'Set the colour of the checked box
     Else
          .Font.Color = wdColorAutomatic 'Set the colour of the unchecked box
     End If
End With
 

When you request an autotext entry, Word looks into the active template first, then in add in templates and finally in the normal template. This appears rather complex to arrange with vba.

Sub InsertMyAutotext()
Dim oAT As AutoTextEntry
Dim oTemplate As Template
Dim oAddin As AddIn
Dim strText As String
Dim bFound As Boolean

'Define the required autotext entry
strText = "AutoText Name"
'Set the found flag default to False
bFound = False
'Ignore the attached template for now if the
'document is based on the normal template
If ActiveDocument.AttachedTemplate <> NormalTemplate Then
     Set oTemplate = ActiveDocument.AttachedTemplate
     'Check each autotext entry in the attached template
     For Each oAT In oTemplate.AutoTextEntries
          'Look for the autotext name
          If oAT.name = strText Then 'if found insert it
               oTemplate.AutoTextEntries(strText).Insert _
                 Where:=Selection.Range
               'Set the found flag to true
               bFound = True
               'Clean up and stop looking
               Set oTemplate = Nothing
               Exit Sub
          End If
     Next oAT
End If
 

'Autotext entry was not found
If bFound = False Then
     For Each oAddin In AddIns
          'Check currently loaded add-ins
          If oAddin.Installed = False Then Exit For
          Set oTemplate = Templates(oAddin.Path & _
            Application.PathSeparator & oAddin.name)
          'Check each autotext entry in the current attached template
          For Each oAT In oTemplate.AutoTextEntries
               If oAT.name = strText Then 'if found insert it
                    oTemplate.AutoTextEntries(strText).Insert _
                      Where:=Selection.Range
                    'Set the found flag to true
                    bFound = True
                    'Clean up and stop looking
                    Set oTemplate = Nothing
                    Exit Sub
               End If
          Next oAT
     Next oAddin
End If

'The entry has not been found check the normal template
If bFound = False Then
     For Each oAT In NormalTemplate.AutoTextEntries
          If oAT.name = strText Then
               NormalTemplate.AutoTextEntries(strText).Insert _
                 Where:=Selection.Range
               bFound = True
               Exit For
          End If
     Next oAT
End If
 

Word 2007 introduced building blocks which added a whole lot of other parameters and a separate building blocks template where autotext entries could be stored. Provided the autotext entry that you wish to insert is defined in the autotext gallery (or it is included in a Word 97-2003 format template or add-in, then the above macro will work as it stands. If you want to check all the galleries, then you will need some extra code. In addition to checking the active template, add-in templates and the normal template, the following finally looks in the building blocks.dotx template.

Sub InsertMyBuildingBlock()
Dim strText As String
Dim oTemplate As Template
Dim oAddin As AddIn
Dim bFound As Boolean
Dim i As Long

'Define the required building block entry
strText = "Building Block Name"

'Set the found flag default to False
bFound = False
'Ignore the attached template for now if the
'document is based on the normal template
If ActiveDocument.AttachedTemplate <> NormalTemplate Then
     Set oTemplate = ActiveDocument.AttachedTemplate
     'Check each building block entry in the attached template
     For i = 1 To oTemplate.BuildingBlockEntries.Count
          'Look for the building block name
          'and if found, insert it.
          If oTemplate.BuildingBlockEntries(i).name = strText Then
               oTemplate.BuildingBlockEntries(strText).Insert _
                 Where:=Selection.Range
               'Set the found flag to true
               bFound = True
               'Clean up and stop looking
               Set oTemplate = Nothing
               Exit Sub
          End If
     Next i
End If
 

'The entry has not been found
If bFound = False Then
     For Each oAddin In AddIns
          'Check currently loaded add-ins
          If oAddin.Installed = False Then Exit For
          Set oTemplate = Templates(oAddin.Path & _
            Application.PathSeparator & oAddin.name)
          'Check each building block entry in the each add in
          For i = 1 To oTemplate.BuildingBlockEntries.Count
               If oTemplate.BuildingBlockEntries(i).name = strText Then
                    'Look for the building block name
                    'and if found, insert it.
                    oTemplate.BuildingBlockEntries(strText).Insert _
                      Where:=Selection.Range
                    'Set the found flag to true
                    bFound = True
                    'Clean up and stop looking
                    Set oTemplate = Nothing
                    Exit Sub
               End If
          Next i
     Next oAddin
End If
 

'The entry has not been found. Check the normal template
If bFound = False Then
     For i = 1 To NormalTemplate.BuildingBlockEntries.Count
          If NormalTemplate.BuildingBlockEntries(i).name = strText Then
               NormalTemplate.BuildingBlockEntries(strText).Insert _
                 Where:=Selection.Range
               'set the found flag to true
               bFound = True
               Exit Sub
          End If
     Next i
End If
 

'If the entry has still not been found
'finally check the Building Blocks.dotx template
If bFound = False Then

     Templates.LoadBuildingBlocks
     For Each oTemplate In Templates
          If oTemplate.name = "Building Blocks.dotx" Then Exit For
     Next
     For i = 1 To Templates(oTemplate.FullName).BuildingBlockEntries.Count
          If Templates(oTemplate.FullName).BuildingBlockEntries(i).name = strText Then
               Templates(oTemplate.FullName).BuildingBlockEntries(strText).Insert _
                 Where:=Selection.Range
               'set the found flag to true
               bFound = True
               'Clean up and stop looking
               Set oTemplate = Nothing
               Exit Sub
          End If
     Next i
End If

'All sources have been checked and the entry is still not found
If bFound = False Then 'so tell the user.
     MsgBox "Entry not found", vbInformation, "Building Block " _
       & Chr(145) & strText & Chr(146)
End If
End Sub
 

The following example uses a pair of arrays to hold corresponding lists of words, characters or phrases separated by commas. Items from the first list are replaced with the corresponding item from the second list

vFindText = Array(Chr(147), Chr(148), Chr(145), Chr(146))
vReplText = Array(Chr(34), Chr(34), Chr(39), Chr(39))

Sub ReplaceQuotes()
Dim vFindText As Variant
Dim vReplText As Variant
Dim sFormat As Boolean
Dim sQuotes As String
Dim i As Long

'Ask the user whether to format with smart or straight quotes
sQuotes = MsgBox("Click 'Yes' to convert smart quotes to straight quotes." & vbCr & _
"Click 'No' to convert straight quotes to smart quotes.", _
vbYesNo, "Convert quotes")

'Record the current setting of the autoformat option to replace straight quotes with smart quotes
sFormat = Options.AutoFormatAsYouTypeReplaceQuotes

If sQuotes = vbYes Then 'The user has clicked 'Yes'

     'Define the lists of smart quotes and their replacements
     vFindText = Array(Chr(147), Chr(148), Chr(145), Chr(146))
     vReplText = Array(Chr(34), Chr(34), Chr(39), Chr(39))

     'Set the autoformat option to replace straight quotes with smart quotes to off
     Options.AutoFormatAsYouTypeReplaceQuotes = False

     'Start from the top of the document
     Selection.HomeKey wdStory
     With Selection.Find
          .Forward = True
          .Wrap = wdFindContinue
          .MatchWholeWord = True
          .MatchWildcards = False
          .MatchSoundsLike = False
          .MatchAllWordForms = False
          .Format = True
          .MatchCase = True

          'replace each item from the first array with the corresponding item in the second array
          For i = LBound(vFindText) To UBound(vFindText)
               .Text = vFindText(i)
               .Replacement.Text = vReplText(i)
               .Execute Replace:=wdReplaceAll
          Next i
     End With
Else 'User clicked 'No'

     'Use autoformat to replace straight quotes with smart quotes

     Options.AutoFormatReplaceQuotes = True
     Selection.Range.AutoFormat
End If

Sub ReplaceFromTableList()
Dim ChangeDoc, RefDoc As Document
Dim cTable As Table
Dim oFind, oReplace As Range
Dim i As Long
Dim sFname As String
'Define the document containing the table of words/phrases and their replacements
sFname = "D:\My Documents\Test\changes.doc"

'Define the document to be processed
Set RefDoc = ActiveDocument

'Open the document with the changes
Set ChangeDoc = Documents.Open(sFname)

'Define the table to be used
Set cTable = ChangeDoc.Tables(1)

'Activate the document to be processed
RefDoc.Activate
For i = 1 To cTable.Rows.Count

     'Define the cell containing the word/phrase to be replaced
     Set oFind = cTable.Cell(i, 1).Range
     oFind.End = oFind.End - 1

     'Define the cell containing the replacement word/phrase
     Set oReplace = cTable.Cell(i, 2).Range
     oReplace.End = oReplace.End - 1
     With Selection

          'Start at the top of the document
          .HomeKey wdStory

          'Replace the words/phrases
          With .Find
               .ClearFormatting
               .Replacement.ClearFormatting
               .Execute findText:=oFind, _
                 ReplaceWith:=oReplace, _
                 Replace:=wdReplaceAll, _
                 MatchWholeWord:=True, _
                 MatchWildcards:=False, _
                 MatchCase:=True, _

                 Forward:=True, _
                 Wrap:=wdFindContinue
          End With
     End With
Next i

'Close the document with the table
ChangeDoc.Close wdDoNotSaveChanges

The final example in this trilogy of replacements using lists was prompted by a newsgroup question. The user wanted initially to highlight words and phrases in a document from a list, which was easily achieved using a variation of one of the above macros, and the he ventured the possibility of the user choosing from a number of possible replacements. How practical this is in a real life situation I cannot say, but the principles involved I felt were interesting enough to repeat them here.

In this instance the macro uses a multi-column table. The first column contains the words to be located, the subsequent columns contain the replacement choices. The columns should be filled from left to right. Not all the columns (except the first) need contain any data, but the columns must be filled from left to right with no gaps.

If only the second column has data, the found item is replaced with the content of the second column

If more columns to the right of the second column have data, the choices from the second and subsequent columns are presented as numbered choices in a list.

If none of the columns, except the first, contains data, then the found word is merely highlighted.

Sub ReplaceFromTableChoices()
Dim ChangeDoc, RefDoc As Document
Dim cTable As Table
Dim oldPart, newPart, oFound As Range
Dim i, j, iCol As Long
Dim sFname, sReplaceText, sNum As String
'Define the document containing the table of changes.

'The table must have at least 3 columns.
sFname = "D:\My Documents\Test\changes2.doc"

'Define the document to be processed
Set RefDoc = ActiveDocument
Set ChangeDoc = Documents.Open(sFname)

'Define the table to be used
Set cTable = ChangeDoc.Tables(1)

'Activate the document to be processed
RefDoc.Activate

'Process each row of the table in turn

For i = 1 To cTable.Rows.Count

     'Set the search item to the content of the first cell
     Set oldPart = cTable.Cell(i, 1).Range

     'Remove the cell end character from the range
     oldPart.End = oldPart.End - 1

     'Start from the beginning of the document
     With Selection
          .HomeKey wdStory
          With .Find
               .ClearFormatting
               .Replacement.ClearFormatting
               .MatchWholeWord = True
               .MatchCase = True

               'Look for the search item
               Do While .Execute(findText:=oldPart)

                    'And assign the found item to a range variable
                    Set oFound = Selection.Range

                    'Set the start number of a counter
                    iCol = 1

                    'Set a temporary replacement text string to zero length
                    sReplaceText = ""

                    'Look into the remaining columns for replacement choices
                    For j = 2 To cTable.Columns.Count

                         'And assign the replacement choices to a range variable in turn
                         Set newPart = cTable.Cell(i, j).Range

                         'Remove the cell end character from the range
                         newPart.End = newPart.End - 1

                         'If the current cell has no content, ignore the remainder
                         If Len(newPart) = 0 Then Exit For

                         'Add the range content to the temporary replacement text string
                         sReplaceText = sReplaceText & iCol & ". " & _
                         newPart.Text & vbCr

                         'Increment the counter
                         iCol = iCol + 1
                    Next j

                     'If there is a replacement available
                    If Len(sReplaceText) <> 0 Then

                         'If there is only one such replacement
                         If Len(cTable.Cell(i, 2).Range) <> 2 And _
                         Len(cTable.Cell(i, 3).Range) = 2 Then
                              'Set the number of that replacement to 1

                              sNum = "1"
                         Else
Again: 'Add a label to mark the start of the user input

                              'If there is more than one choice,

                              'ask the user to pick the preferred replacement
                              sNum = InputBox(sReplaceText & vbCr & vbCr & _
                              "Enter the number of the replacement for '" _
                              & oldPart.Text & "'")
                              If sNum = "" Then Exit Sub 'The user has cancelled

                              'Error trap inappropriate user choices

                              'Check if the user has entered something other than a number
                              If IsNumeric(sNum) = False Then

                                   'Tell the user
                                   MsgBox "Invalid entry! Try again.", _
                                   vbInformation, "Error"

                                   'and go round again
                                   GoTo Again
                              End If

                              'Check if the user has entered a number

                              'higher than the number of columns in the table
                              If sNum > cTable.Columns.Count Then

                                   'Tell the user
                                   MsgBox "Invalid entry! Try again.", _
                                   vbInformation, "Error"

                                   'and go round again
                                   GoTo Again
                              End If

                              'Check if a user has picked a valid number

                              'higher than the available choices
                              If Len(cTable.Cell(i, sNum + 1).Range) = 2 Then
                                   'Tell the user

                                   MsgBox "Invalid entry! Try again.", _
                                   vbInformation, "Error"

                                   'and go round again
                                   GoTo Again
                              End If
                         End If

                         'Set the replacement according to the user input
                         Set newPart = cTable.Cell(i, sNum + 1).Range
                         newPart.End = newPart.End - 1
                         oFound.Text = newPart.Text
                    Else

                         'There are no replacements so highlight the found item
                         oFound.HighlightColorIndex = wdYellow
                    End If
               Loop
          End With
     End With
Next i

Sub AddTabs()
Dim iLeft As Long
Dim iRight As Long
Dim iCentre As Long
Dim iWidth As Long
With Selection
     iLeft = .Sections(1).PageSetup.LeftMargin
     iRight = .Sections(1).PageSetup.RightMargin
     iWidth = .Sections(1).PageSetup.PageWidth
     iCentre = (iWidth - iLeft - iRight) / 2
     .ParagraphFormat.TabStops.Add Position:=iCentre, _
        Alignment:=wdAlignTabCenter, _

        Leader:=wdTabLeaderSpaces
     .ParagraphFormat.TabStops.Add Position:=iWidth - (iRight + iLeft), _
        Alignment:=wdAlignTabRight, _