Replace a list of words from a table and offer a choice of replacements

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.

There must be no empty cells in the first column!

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

'Close the document containing the table
ChangeDoc.Close wdDoNotSaveChanges
End Sub