Friday, September 9, 2011

Date and Time

Dates and times in Excel VBA can be manipulated in many ways. This chapter teaches you how to get the year, month and day of an Excel VBA date, how to add a number of days to a date, how to get the current date and time, how to get the hour, minute and second of the current time and how to convert a string to a time serial number.
Place a command button on your worksheet and add the code lines described in this chapter. To execute the code lines, click the command button on the sheet.

Year, Month, Day of a Date

The following macro gets the year of a date. First, we declare a date using the Dim statement. To initialize a date, we use the DateValue function.
Code:
Dim exampleDate As Date

exampleDate = DateValue("Jun 19, 2010")

MsgBox Year(exampleDate)

Result:
The Result is the Year of the Excel VBA Date
Note: Use Month and Day to get the month and day of a date.

DateAdd

To add a number of days to a date, use the DateAdd function. The DateAdd function has three arguments. Fill in "d" for the first argument since we want to add days. Fill in 3 for the second argument to add 3 days. The third argument represents the date, to which in this example, the number of days will be added.
Code:
Dim firstDate As Date, secondDate As Date

firstDate = DateValue("Jun 19, 2010")
secondDate = DateAdd("d", 3, firstDate)

MsgBox secondDate

Result:
The Result is the Date three days later
Note: Change "d" to "m" to add a number of months to a date. Place your cursor on DateAdd in Excel VBA and click on F1 for help on the other interval specifiers. The format of the date depends on your windows regional settings.

Current Date & Time

To get the current date and time, use the Now function.
Code:
MsgBox Now

Result:
The Result is the Current Date and Time
Note: replace a date, such as “June 19, 2010” with Now and you can use all the functions described above on the current date!

Hour, Minute and Second

The following macro gets the hour of the current time.
Code:
MsgBox Hour(Now)

Result:
The Result is the Hour of the Current Time
Note: Use Minute and Second to get the minute and second of the current time.

TimeValue

The TimeValue function converts a string to a time serial number. The time's serial number is a number between 0 and 1. For example, noon (halfway through the day) is represented as 0.5.
Code:
MsgBox TimeValue("9:20:01 am")

Result:
TimeValue Function Result
Now, to clearly see that Excel handles times internally as numbers between 0 and 1, add the following code lines:
Dim y As Double
y = TimeValue("09:20:01")
MsgBox y

Result:
Time Serial Number
We hope you found this information about date and time functions in Excel VBA useful.

Create a Macro in Excel 2007

Turn on the Developer Tab

1. Click on the File tab and choose Options. The Excel Options dialog box appears (see picture below).

2. Click Customize Ribbon on the left side of the dialog box.
3. Under Choose commands from on the left side of the dialog box, select Popular Commands (if necessary).
4. Under Customize the ribbon on the right side of the dialog box, select Main tabs (if necessary).
5. Check the Developer check box and click OK.
Activate the Developer Tab in Excel 2010

Create a command button

You can now click on the Developer tab which has been placed next to the View tab.
1. Click on Insert.
2. Click on Command Button in the ActiveX Controls section.
Create a Command Button
3. Now you can drag a command button on your worksheet.

Create and Assign the Macro

Now it is time to create a macro (a piece of code) and assign it to the command button.
1. Right click on CommandButton1.
2. Click on View Code.
Assign a Macro
3. The Visual Basic Editor appears. Place you cursor between 'Private Sub CommandButton1_Click()' and 'End Sub'.

4. For example, add the following code line:
Range("A1").Value = "Hello"

Create a Macro in Excel VBA
This macro places the word Hello into cell A1.
5. Close the Visual Basic Editor.
6. Before you click the command button on the sheet, make sure Design Mode is deselected. You can do this by clicking on Design Mode again.
Result when you click the command button on the sheet:
Excel Macro Result
Congratulations. You've just created a macro in Excel VBA!

 For excel 2007

Turn on the Developer Tab

1. Click on the Office button in the upper left corner of your screen.
2. Click on Excel Options. The Excel Options dialog box appears (see picture below).

3. Check Show Developer tab in the Ribbon.
Activate the Developer Tab in Excel 2007

4. Click OK.

Create a command button

You can now click on the Developer tab which has been placed next to the View tab.
1. Click on Insert.
2. Click on Command Button in the ActiveX Controls section.
Create a Command Button in Excel 2007
3. Now you can drag a command button on your worksheet.

Create and Assign the Macro

Now it is time to create a macro (a piece of code) and assign it to the command button.
1. Right click on CommandButton1.
2. Click on View Code.
Assign Code
3. The Visual Basic Editor appears. Place you cursor between 'Private Sub CommandButton1_Click()' and 'End Sub'.

4. For example, add the following code line:
Range("A1").Value = "Hello"

Create a Macro in Excel VBA
This macro places the word Hello into cell A1.
5. Close the Visual Basic Editor.
6. Before you click on CommandButton1, make sure Design Mode is deselected. You can do this by clicking on Design Mode again.
7. Click on CommandButton1.
Cell A1 should contain the word Hello now. Congratulations. You've just created a macro in Excel VBA!

Create a Macro in Excel 2003

Activate the Control Toolbox

In order to use Excel VBA in Excel 2003, you have to activate the Control Toolbox.
1. Click on View, Toolbars, Control Toolbox.

Activate the Control Toolbox in Excel 2003
2. You can integrate the Control Toolbox if you want by simply dragging it into your menu.
Integrate the Control Toolbox

Create a Command Button

1. Click on Command Button from the Control Toolbox.

Click on Command Button
2. Now you can drag a command button on your worksheet.

Create and Assign the Macro

Now it is time to create a macro and assign it to the command button.
1. Right click on CommandButton1.
2. Click on View Code.
Right Click and then click on View Code
3. The Visual Basic Editor appears. Place you cursor between 'Private Sub CommandButton1_Click()' and 'End Sub'.

4. Add the line:
Range("A1").Value = "Hello"

The Visual Basic Editor in Excel 2003
5. Close the Visual Basic Editor.
6. Before you click on the command button, make sure Design Mode (most left field of the Control Toolbox) is deselected. You can do this by clicking on Design Mode again.
7. Click on CommandButton1.
Result:
First Macro Result
Well done! You've just created a macro in Excel VBA!

Compare two lists and delete duplicate items

Sub DelDups_TwoLists()
Dim iListCount As Integer
Dim iCtr As Integer

' Turn off screen updating to speed up macro.
Application.ScreenUpdating = False

' Get count of records to search through (list that will be deleted).
iListCount = Sheets("sheet2").Range("A1:A100").Rows.Count

' Loop through the "master" list.
For Each x In Sheets("Sheet1").Range("A1:A10")
   ' Loop through all records in the second list.
   For iCtr = 1 To iListCount
      ' Do comparison of next record.
      ' To specify a different column, change 1 to the column number.
      If x.Value = Sheets("Sheet2").Cells(iCtr, 1).Value Then
         ' If match is true then delete row.
         Sheets("Sheet2").Cells(iCtr, 1).Delete xlShiftUp
         ' Increment counter to account for deleted row.
         iCtr = iCtr + 1
      End If
   Next iCtr
Next
Application.ScreenUpdating = True
MsgBox "Done!"
End Sub

Sample 1: Delete duplicate items in a single list

Sub DelDups_OneList()
Dim iListCount As Integer
Dim iCtr As Integer

' Turn off screen updating to speed up macro.
Application.ScreenUpdating = False

' Get count of records to search through.
iListCount = Sheets("Sheet1").Range("A1:A100").Rows.Count
Sheets("Sheet1").Range("A1").Select
' Loop until end of records.
Do Until ActiveCell = ""
   ' Loop through records.
   For iCtr = 1 To iListCount
      ' Don't compare against yourself.
      ' To specify a different column, change 1 to the column number.
      If ActiveCell.Row <> Sheets("Sheet1").Cells(iCtr, 1).Row Then
         ' Do comparison of next record.
         If ActiveCell.Value = Sheets("Sheet1").Cells(iCtr, 1).Value Then
            ' If match is true then delete row.
            Sheets("Sheet1").Cells(iCtr, 1).Delete xlShiftUp
               ' Increment counter to account for deleted row.
               iCtr = iCtr + 1
         End If
      End If
   Next iCtr
   ' Go to next record.
   ActiveCell.Offset(1, 0).Select
Loop
Application.ScreenUpdating = True
MsgBox "Done!"
End Sub
    

Macro to Change All Text in a Cell Range to Initial Capital Letters

Sub Proper_Case()
   ' Loop to cycle through each cell in the specified range.
   For Each x In Range("C1:C5")
      ' There is not a Proper function in Visual Basic for Applications.
      ' So, you must use the worksheet function in the following form:
      x.Value = Application.Proper(x.Value)
   Next
End Sub

Macro to Change All Text in a Range to Lowercase Letters

Sub Lowercase()
   ' Loop to cycle through each cell in the specified range.
   For Each x In Range("B1:B5")
      x.Value = LCase(x.Value)
   Next
End Sub
 

Macro to Change All Text in a Range to Uppercase Letters

Sub Uppercase()
   ' Loop to cycle through each cell in the specified range.
   For Each x In Range("A1:A5")
      ' Change the text in the range to uppercase letters.
      x.Value = UCase(x.value)
   Next
End Sub
 

Macro for Support Functions

The following functions are used by the primary functions on this page.
Private Function ArrayElementsInOrder(Arr As Variant, _
    Optional Descending As Boolean = False, _
    Optional Diff As Integer = 0) As Boolean
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' ArrayElementsInOrder
' This function tests an array of integers (Long or Int) to determine
' if they are in order, in ascending or descending sort order, and
' optionally if they all differ by exactly Diff. Diff is the absolute
' value between two adjacent elements. Do not use a negative number
' for a descending sort; Diff should always be greater than 0 to test
' the differences or 0 to ignore differences. The default behavior
' is to test whether the elements are in ascending order with any
' difference between them. Set the Descending and/or Diff parameters
' to change this.
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Dim N As Long
For N = LBound(Arr) To UBound(Arr) - 1
    If Descending = False Then
        If Diff > 0 Then
            If Arr(N) <> Arr(N + 1) - Diff Then
                ArrayElementsInOrder = False
                Exit Function
            End If
        Else
            If Arr(N) > Arr(N + 1) Then
                ArrayElementsInOrder = False
                Exit Function
            End If
        End If
    Else
        If Diff > 0 Then
            If Arr(N) <> Arr(N + 1) + Diff Then
                ArrayElementsInOrder = False
                Exit Function
            End If
        Else
            If Arr(N) < Arr(N + 1) Then
                ArrayElementsInOrder = False
                Exit Function
            End If
        End If
    End If
Next N
ArrayElementsInOrder = True
End Function



Private Function TestFirstLastSort(FirstToSort As Long, LastToSort As Long, _
    ByRef ErrorText As String) As Boolean
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' TestFirstLastSort
' This ensures FirstToSort and LastToSort are valid values. If successful,
' returns True and sets ErrorText to vbNullString. If unsuccessful, returns
' False and set ErrorText to the reason for failure.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
ErrorText = vbNullString
If FirstToSort <= 0 Then
    TestFirstLastSort = False
    ErrorText = "FirstToSort is less than or equal to 0."
    Exit Function
End If

If FirstToSort > Worksheets.Count Then
    TestFirstLastSort = False
    ErrorText = "FirstToSort is greater than number of sheets."
    Exit Function
End If

If LastToSort <= 0 Then
    TestFirstLastSort = False
    ErrorText = "LastToSort is less than or equal to 0."
    Exit Function
End If

If LastToSort > Worksheets.Count Then
    TestFirstLastSort = False
    ErrorText = "LastToSort greater than number of sheets."
    Exit Function
End If

If FirstToSort > LastToSort Then
    TestFirstLastSort = False
    ErrorText = "FirstToSort is greater than LastToSort."
    Exit Function
End If
    
TestFirstLastSort = True

End Function


Private Function IsArrayAllocated(Arr As Variant) As Boolean
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' IsArrayAllocated
' Returns True or False indicating if Arr is an allocated
' array.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    On Error Resume Next
    Dim V As Variant
    IsArrayAllocated = True
    V = Arr(LBound(Arr, 1))
    If IsError(V) = True Then
        IsArrayAllocated = False
    End If
    If (UBound(Arr, 1) < LBound(Arr, 1)) Then
        IsArrayAllocated = False
    End If
    
End Function

Private Function SheetExists(WSName As String, Optional WB As Workbook = Nothing) As Boolean
''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' SheetExists
' Returns True if worksheet named by WSName exists in
' Workbook WB. If WB is omitted,
' the ActiveWorkbook is used.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''
On Error Resume Next
SheetExists = IsError(IIf(WB Is Nothing, ActiveWorkbook, WB).Worksheets(WSName)) = False

End Function

macro for Group Sheets By Color

The GroupSheetsByColor function groups sheets by their tab color (available only in Excel 2002 and later). You specify in an array the colors and the order in which those colors should appear. The sheets are grouped according to those color indicators. The color indicators are the ColorIndex values, not actual RGB colors. The declaration for GroupSheetsByColor is shown below:

Public Function GroupSheetsByColor(ByVal FirstToSort As Long, ByVal LastToSort As Long, _ ByRef ErrorText As String, ColorArray() As Long) As Boolean
FirstToSort is the index (position) number of the first sheet to sort.

LastToSort is the index (position) number of the last sheet to sort. If both FirstToSort and LastSheetToSort are less than or equal to 0, all sheets are sorted.

ErrorText is a variable that will contain the error message if an error occurs.

ColorArray is an array of longs indicating the colors and order in which the sheets should be grouped.
The code is shown below:
Public Function GroupSheetsByColor(ByVal FirstToSort As Long, ByVal LastToSort As Long, _
    ByRef ErrorText As String, ColorArray() As Long) As Boolean
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' GroupSheetsByColor
' This groups worksheets by color. The order of the colors
' to group by must be the ColorIndex values stored in
' ColorsArray.
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

Dim WB As Workbook
Dim B As Boolean
Dim N1 As Long
Dim N2 As Long
Dim N3 As Long
Dim CI1 As Long
Dim CI2 As Long
Dim CArray As Variant

Dim CNdx1 As Long
Dim Cndx2 As Long

Const MIN_COLOR_INDEX = 1
Const MAX_COLOR_INDEX = 56


If IsArrayAllocated(ColorArray) = False Then
    ErrorText = "ColorArray is not a valid, allocated array."
    GroupSheetsByColor = False
    Exit Function
End If


Set WB = Worksheets.Parent
ErrorText = vbNullString


''''''''''''''''''''''''''''''''''''''
' Setup ColorIndex array
'''''''''''''''''''''''''''''''''''''
If IsMissing(ColorArray) = False Then
    If IsArray(ColorArray) = False Then
        ErrorText = "ColorArray is not an array"
        GroupSheetsByColor = False
        Exit Function
    End If
Else
    ''''''''''''''''''''''''''''''''''''''
    ' Ensure all color indexes are valid.
    ''''''''''''''''''''''''''''''''''''''
    For N1 = LBound(ColorArray) To UBound(ColorArray)
        If (ColorArray(N1) > MAX_COLOR_INDEX) Or (ColorArray(N1) < MIN_COLOR_INDEX) Then
            ErrorText = "Invalid ColorIndex in ColorArray"
            GroupSheetsByColor = False
            Exit Function
        End If
    Next N1
End If

Set WB = Worksheets.Parent

ErrorText = vbNullString

If (FirstToSort <= 0) And (LastToSort <= 0) Then
    FirstToSort = 1
    LastToSort = WB.Worksheets.Count
End If

B = TestFirstLastSort(FirstToSort, LastToSort, ErrorText)
If B = False Then
    GroupSheetsByColor = False
    Exit Function
End If

For N1 = FirstToSort To LastToSort
    If WB.Worksheets(N1).Tab.ColorIndex = ColorArray(LBound(ColorArray)) Then
        WB.Worksheets(N1).Move before:=WB.Worksheets(1)
        Exit For
    End If
Next N1
N3 = 1
For N2 = LBound(ColorArray) To UBound(ColorArray)
    For N1 = 2 To LastToSort
        If WB.Worksheets(N1).Tab.ColorIndex = ColorArray(N2) Then
            WB.Worksheets(N1).Move after:=WB.Worksheets(N3)
            N3 = N3 + 1
        End If
        
    Next N1
Next N2

GroupSheetsByColor = True

End Function

Macro for SortWorksheetsByNameArray

The SortWorksheetByNameArray function sorts the worksheets in the order of the names passed as n array. While the individual elements of the array need not refer to adjacent worksheets, the worksheets, taken as a group, named by the values in the arrray, must be adjacent. You cannot sort non-adjacent sheets. The function returns True if successful or False if an error occurred. If an error occurred, the variable ErrorText will contain the text of the error message.

The declaration of SortWorksheetsByNameArray declaration is shown below:

Public Function SortWorksheetsByNameArray(NameArray() As Variant, ByRef ErrorText As String) As Boolean

NameArray is an array containing the worksheet names in the order that they should be ordered.
The code for SortWorksheetsByNameArray is shown below:
Public Function SortWorksheetsByNameArray(NameArray() As Variant, ByRef ErrorText As String) As Boolean
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' WorksheetSortByArray
' This procedure sorts the worksheets named in NameArray to the order in
' which they appear in NameArray. The adjacent elements in NameArray need
' not be adjacent sheets, but the collection of all sheets named in
' NameArray must form a set of adjacent sheets. If successful, returns
' True and ErrorText is vbNullString. If failure, returns False and
' ErrorText contains reason for failure.
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Dim Arr() As Long
Dim N As Long
Dim M As Long
Dim L As Long
Dim WB As Workbook

ErrorText = vbNullString

'''''''''''''''''''''''''''''''''''''''''''''''
' The NameArray need not contain all of the
' worksheets in the workbook, but the sheets
' that it does name together must form a group of
' adjacent sheets. Sheets named in NameArray
' need not be adjacent in the NameArray, only
' that when all sheet taken together, they form an
' adjacent group of sheets
'''''''''''''''''''''''''''''''''''''''''''''''
ReDim Arr(LBound(NameArray) To UBound(NameArray))
On Error Resume Next
For N = LBound(NameArray) To UBound(NameArray)
    '''''''''''''''''''''''''''''''''''''''
    ' Ensure all sheets in name array exist
    '''''''''''''''''''''''''''''''''''''''
    Err.Clear
    M = Len(WB.Worksheets(NameArray(N)).Name)
    If Err.Number <> 0 Then
        ErrorText = "Worksheet does not exist."
        SortWorksheetsByNameArray = False
        Exit Function
    End If
    '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    ' Put the index value of the sheet into Arr. Ensure there
    ' are no duplicates. If Arr(N) is not zero, we've already
    ' loaded that element of Arr and thus have duplicate sheet
    ' names.
    '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    If Arr(N) > 0 Then
        ErrorText = "Duplicate worksheet name in NameArray."
        SortWorksheetsByNameArray = False
        Exit Function
    End If
        
    Arr(N) = Worksheets(NameArray(N)).Index
Next N

'''''''''''''''''''''''''''''''''''''''
' Sort the sheet indexes. We don't use
' these for the sorting order, but we
' do use them to ensure that the group
' of sheets passed in NameArray are
' together contiguous.
'''''''''''''''''''''''''''''''''''''''
For M = LBound(Arr) To UBound(Arr)
    For N = M To UBound(Arr)
        If Arr(N) < Arr(M) Then
            L = Arr(N)
            Arr(N) = Arr(M)
            Arr(M) = L
        End If
    Next N
Next M
''''''''''''''''''''''''''''''''''''''''
' Now that Arr is sorted ascending, ensure
' that the elements are in order differing
' by exactly 1. Otherwise, sheet are not
' adjacent.
'''''''''''''''''''''''''''''''''''''''''
If ArrayElementsInOrder(Arr:=Arr, Descending:=False, Diff:=1) = False Then
    ErrorText = "Specified sheets are not adjacent."
    SortWorksheetsByNameArray = False
    Exit Function
End If

''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Now, do the actual move of the sheets.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''
On Error GoTo 0
WB.Worksheets(NameArray(LBound(NameArray))).Move before:=WB.Worksheets(Arr(1))
For N = LBound(NameArray) + 1 To UBound(NameArray) - 1
    WB.Worksheets(NameArray(N)).Move before:=WB.Worksheets(NameArray(N + 1))
Next N

SortWorksheetsByNameArray = True

End Function

MAcro for Sorting By Name

his function allows you to sort some or all worksheets based on their names, in either ascending or descending order. You also have the option of specifying whether to sort numeric sheet names as numbers or as text. For example, the following are numeric sheet names sorted as text: 11, 115, 22. Sorted as numeric, the order would be 11, 22,115. If you omit the Numeric parameter, it is treated as False and the sort will use a text value sort rather than numeric value sort. If this parameter is True, all of the sheets that are to be sorted must have a numeric name. Otherwise, the function will quit with a result of False. The function declaration is:
Public Function SortWorksheetsByName(ByVal FirstToSort As Long, ByVal LastToSort As Long, _
    ByRef ErrorText As String, Optional ByVal SortDescending As Boolean = False) As Boolean
FirstToSort is the index (position) of the first worksheet to sort.

LastToSort is the index (position) of the laset worksheet to sort. If either both FirstToSort and LastToSort are less than or equal to 0, all sheets in the workbook are sorted.

ErrorText is a variable that will receive the text description of any error that may occur.

SortDescending is an optional parameter to indicate that the sheets should be sorted in descending order. If True, the sort is in descending order. If omitted or False, the sort is in ascending order.

The function returns True if successful. If an error occurs, the function returns False and the variable ErrorText is set to the text of the error message.
The code for SortWorksheetsByName is shown below.
Public Function SortWorksheetsByName(ByVal FirstToSort As Long, _
                            ByVal LastToSort As Long, _
                            ByRef ErrorText As String, _
                            Optional ByVal SortDescending As Boolean = False, _
                            Optional ByVal Numeric As Boolean = False) As Boolean
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' SortWorksheetsByName
' This sorts the worskheets from FirstToSort to LastToSort by name
' in either ascending (default) or descending order. If successful,
' ErrorText is vbNullString and the function returns True. If
' unsuccessful, ErrorText gets the reason why the function failed
' and the function returns False. If you include the Numeric
' parameter and it is True, (1) all sheet names to be sorted
' must be numeric, and (2) the sort compares names as numbers, not
' text.
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Dim M As Long
Dim N As Long
Dim WB As Workbook
Dim B As Boolean

Set WB = Worksheets.Parent
ErrorText = vbNullString

If WB.ProtectStructure = True Then
    ErrorText = "Workbook is protected."
    SortWorksheetsByName = False
End If
    
'''''''''''''''''''''''''''''''''''''''''''''''
' If First and Last are both 0, sort all sheets.
''''''''''''''''''''''''''''''''''''''''''''''
If (FirstToSort = 0) And (LastToSort = 0) Then
    FirstToSort = 1
    LastToSort = WB.Worksheets.Count
Else
    '''''''''''''''''''''''''''''''''''''''
    ' More than one sheet selected. We
    ' can sort only if the selected
    ' sheet are adjacent.
    '''''''''''''''''''''''''''''''''''''''
    B = TestFirstLastSort(FirstToSort, LastToSort, ErrorText)
    If B = False Then
        SortWorksheetsByName = False
        Exit Function
    End If
End If

If Numeric = True Then
    For N = FirstToSort To LastToSort
        If IsNumeric(WB.Worksheets(N).Name) = False Then
            ' can't sort non-numeric names
            ErrorText = "Not all sheets to sort have numeric names."
            SortWorksheetsByName = False
            Exit Function
        End If
    Next N
End If

'''''''''''''''''''''''''''''''''''''''''''''
' Do the sort, essentially a Bubble Sort.
'''''''''''''''''''''''''''''''''''''''''''''
For M = FirstToSort To LastToSort
    For N = M To LastToSort
        If SortDescending = True Then
            If Numeric = False Then
                If StrComp(WB.Worksheets(N).Name, WB.Worksheets(M).Name, vbTextCompare) > 0 Then
                    WB.Worksheets(N).Move before:=WB.Worksheets(M)
                End If
            Else
                If CLng(WB.Worksheets(N).Name) > CLng(WB.Worksheets(M).Name) Then
                    WB.Worksheets(N).Move before:=WB.Worksheets(M)
                End If
            End If
        Else
            If Numeric = False Then
                If StrComp(WB.Worksheets(N).Name, WB.Worksheets(M).Name, vbTextCompare) < 0 Then
                    WB.Worksheets(N).Move before:=WB.Worksheets(M)
                End If
            Else
                If CLng(WB.Worksheets(N).Name) < CLng(WB.Worksheets(M).Name) Then
                    WB.Worksheets(N).Move before:=WB.Worksheets(M)
                End If
            End If
        End If
    Next N
Next M

SortWorksheetsByName = True

End Function

Sheet Names

It is very simple to retrieve sheet names in VBA.  They are stored in two collection objects in the ActiveWorkbook object: the Sheets collection and the Worksheets collection.  The Sheets collection contains both worksheets and chart sheets.   The Worksheets collection contains only worksheets.
To retrieve the name of the first sheet in the workbook, use
Public Function FirstSheetName()
    FirstSheetName = Sheets(1).Name
End Function

To retrieve the name of the last sheet in the workbook, use
Public Function LastSheetName()
    LastSheetName = Sheets(Sheets.Count).Name
End Function

You can return an array of all the sheet names with the following
Public Function AllSheetNames()
    Dim Arr() As String
    Dim I as Integer
    Redim Arr(Sheets.Count-1)
    For I = 0 To Sheets.Count - 1
        Arr(i) = Sheets(I+1).Name
    Next I
    AllSheetNames = Arr      ' return a row array OR
    AllSheetNames = Application.Worksheetfunction.Transpose(Arr)
                             ' return a column array
End Function

Selecting The Current Named Range

If the ActiveCell is part of a named range, this macro will select the entire named range.
This macro requires the CellInNamedRange function, shown first.

CellInNamedRange
Public Function CellInNamedRange(Rng As Range) As String

Dim N As Name
Dim C As Range
Dim TestRng As Range
On Error Resume Next

For Each N In ActiveWorkbook.Names
    Set C = Nothing
    Set TestRng = N.RefersToRange
    Set C = Application.Intersect(TestRng, Rng)
    If Not C Is Nothing Then
        CellInNamedRange = N.Name
        Exit Function
    End If
Next N
CellInNamedRange = ""

End Function

SelectRange
Public Sub SelectRange()

Dim RngName As String
Dim R As Range
Set R = ActiveCell
Dim Msg As String

Msg = "Active Cell Is Not In A Named Range."
RngName = CellInNamedRange(R)
If RngName <> "" Then
    Range(RngName).Select
    Msg = "Range: " + RngName + " Selected."
End If

Application.StatusBar = Msg

End Sub

Selecting The Current Array

If the ActiveCell is part of an array, this macro will select the entire array.
Public Sub SelectArray()

Dim Msg As String

On Error GoTo EndOfMacro
Msg = "Cell is not part of an array."

ActiveCell.CurrentArray.Select
Msg = "Array Selected."


EndOfMacro:
Application.StatusBar = Msg

End Sub

Saving All Workbooks

This macro will save all of the workbooks open in Excel.
Public Sub SaveAll()

Dim WB As Workbook
For Each WB In Workbooks
    WB.Save
Next WB
Application.StatusBar = "All Workbooks Saved."

End Sub


Saving And Returning To A Location

These three macros are used to save a location and then return to that location later.   It is
useful when you need to change the Selection range during the execution of a macro, and then
return to the original Selection range when your macro is complete.

Public Sub SaveLocation(ReturnToLoc As Boolean)

Static WB As Workbook
Static WS As Worksheet
Static R As Range

If ReturnToLoc = False Then
    Set WB = ActiveWorkbook
    Set WS = ActiveSheet
    Set R = Selection
Else
    WB.Activate
    WS.Activate
    R.Select
End If

End Sub

To save the current location, call SetSaveLoc.
Public Sub SetSaveLoc()
    SaveLocation (False)
End Sub

To return to the saved location, call GetSaveLoc.
Public Sub GetSaveLoc()
    SaveLocation (True)
End Sub

Printing Formulas To Word

This macro will print all of the cell values and formulas to Microsoft Word.  The Word application will
remain open and active.  You may then save or print the document.  Make sure that
you have enabled references to Word objects, from the Tools->References menu. 

Public Sub PrintFormulasToWord()

Dim Cnt As String
Dim C As Range

Dim WordObj As word.Application
Dim HasArr As Boolean

On Error Resume Next
Err.Number = 0

Set WordObj = GetObject(, "Word.Application")
If Err.Number = 429 Then
    Set WordObj = CreateObject("Word.Application")
    Err.Number = 0
End If

WordObj.Visible = True
WordObj.Documents.Add

With WordObj.Selection
    .Font.Name = "Courier New"
    .TypeText "Formulas In Worksheet: " + ActiveSheet.Name    
    .TypeParagraph
    .TypeText "Cells: " + Selection.Cells(1,1).Address(False,False,xlA1) _             & " to " & Selection.Cells(Selection.Rows.Count,  _
            Selection.Columns.Count).Address(False, False, xlA1)
    .TypeParagraph
    .TypeParagraph
End With

For Each C In Selection
    HasArr = C.HasArray
    Cnt = C.Formula
    If HasArr Then
        Cnt = "{" + Cnt + "}"
    End If
    If Cnt <> "" Then
        With WordObj.Selection
            .Font.Bold = True
            .TypeText C.Address(False, False, xlA1) & ": "
            .Font.Bold = False
            .TypeText Cnt
            .TypeParagraph
            .TypeParagraph
        End With
    End If
Next C
MsgBox "Done printing formulas to Word. ", , "Print Formulas To Word"

End Sub

Printing Comments To Word

This macro will print all of the cell comments to Microsoft Word.  The Word application will remain
open and active.  You may then save or print the cell comment document.    Make sure that
you have enabled references to Word objects, from the Tools->References menu.

Public Sub PrintCellComments()

Dim Cmt As String
Dim C As Range
Dim I As Integer
Dim WordObj As Object
Dim ws As Worksheet
Dim PrintValue As Boolean
Dim res As Integer
On Error Resume Next
Err.Number = 0

res = MsgBox("Do want to print cell values with comments?", _
    vbYesNoCancel + vbQuestion, "Print Cell Comments")
Select Case res
    Case vbCancel
        Exit Sub
    Case vbYes
        PrintValue = True
    Case Else
        PrintValue = False
End Select

Set WordObj = GetObject(, "Word.Application")
If Err.Number = 429 Then
    Set WordObj = CreateObject("Word.Application")
    Err.Number = 0
End If

WordObj.Visible = True
WordObj.Documents.Add
With WordObj.Selection
.TypeText Text:="Cell Comments In Workbook: " + ActiveWorkbook.Name
.TypeParagraph
.TypeText Text:="Date: " + Format(Now(), "dd-mmm-yy hh:mm")
.TypeParagraph
.TypeParagraph
End With

For Each ws In Worksheets
    For I = 1 To ws.Comments.Count
        Set C = ws.Comments(I).Parent
        Cmt = ws.Comments(I).Text
        With WordObj.Selection
        .TypeText Text:="Comment In Cell: " + _
            C.Address(False, False, xlA1) + " on sheet: " + ws.Name
        If PrintValue = True Then
            .TypeText Text:=" Cell Value: " + Format(C.Value)
        End If
        .TypeParagraph
        .TypeText Text:=Cmt
        .TypeParagraph
        .TypeParagraph
        End With
    Next I
Next ws

Set WordObj = Nothing
MsgBox "Finished Printing Comments To Word", vbInformation, _
    "PrintCellComments"

End Sub

Highlighting The Active Cell

If you want to make the active cell appear in a special color, use the following code in the Workbook_SheetSelectionChange event of the workbook.
Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object,
    ByVal Target As Excel.Range)
Static OldRange As Range
On Error Resume Next
Target.Interior.ColorIndex = 6 ' yellow - change as needed
OldRange.Interior.ColorIndex = xlColorIndexNone
Set OldRange = Target

End Sub

Headers And Footers

From the Page Setup dialog, you can set up some basic headers and footers, but you're somewhat limited.  With VBA, however, you can create your own custom headers and footers:
Activesheet.Pagesetup.Leftfooter = "Some Text"
In addition to Leftfooter, you can use CenterFooter, RightFooter, LeftHeader, CenterHeader,or RightHeader.
To include one of the built-in document properties in a footer (or header), use
Activesheet.Pagesetup.Leftfooter =     ActiveWorkbook.Builtinproperties("Manager")
Of course, change "Manager" to the name of the property you want to include.

Getting A Built-In Or Custom Document Property

This macro will return the value of a custom or built-in document property.  If the property does not exist, and empty string is returned.
Public Function GetProperty(p As String)
Dim S As Variant

On Error Resume Next

S = ActiveWorkbook.CustomDocumentProperties(p)
If S <> "" Then
    GetProperty = S
    Exit Function
End If

On Error GoTo EndMacro
GetProperty = ActiveWorkbook.BuiltinDocumentProperties(p)
Exit Function

EndMacro:
GetProperty = ""

End Function

Flipping Or Mirroring A Range

This macro will reverse the order of a range of data.  You may flip data in a single row or in a single column of data (i.e., an N by 1 array or an 1 by N array).   You may not select and entire row or an entire column.
Public Sub FlipSelection()

Dim Arr() As Variant
Dim Rng As Range
Dim C As Range
Dim Rw As Long
Dim Cl As Long

On Error GoTo EndMacro

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.EnableEvents = False

Set Rng = Selection
Rw = Selection.Rows.Count
Cl = Selection.Columns.Count
If Rw > 1 And Cl > 1 Then
   MsgBox "Selection May Include Only 1 Row or 1 Column", _
    vbExclamation, "Flip Selection"
Exit Sub
End If

If Rng.Cells.Count = ActiveCell.EntireRow.Cells.Count Then
    MsgBox "You May Not Select An Entire Row", vbExclamation, _
        "Flip Selection"
    Exit Sub
End If
If Rng.Cells.Count = ActiveCell.EntireColumn.Cells.Count Then
    MsgBox "You May Not Select An Entire Column", vbExclamation, _
        "Flip Selection"
    Exit Sub
End If

If Rw > 1 Then
    ReDim Arr(Rw)
Else
    ReDim Arr(Cl)
End If

Rw = 0
For Each C In Rng
    Arr(Rw) = C.Formula
    Rw = Rw + 1
Next C

Rw = Rw - 1
For Each C In Rng
    C.Formula = Arr(Rw)
    Rw = Rw - 1
Next C

EndMacro:
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Application.EnableEvents = True

End Sub

DeleteDuplicateRows

This macro will delete duplicate rows in a range.  To use, select a single-column range of cells, comprising the range of rows from which duplicates are to be deleted, e.g., C2:C99.   To determine whether a row has duplicates, the values in the selected column are compared. Entire rows are not compared against one another.  Only the selected column is used for comparison.  When duplicate values are found in the active column, the first row remains, and all subsequent rows are deleted.

Public Sub DeleteDuplicateRows()
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' DeleteDuplicateRows
' This will delete duplicate records, based on the Active Column. That is,
' if the same value is found more than once in the Active Column, all but
' the first (lowest row number) will be deleted.
'
' To run the macro, select the entire column you wish to scan for
' duplicates, and run this procedure.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

Dim R As Long
Dim N As Long
Dim V As Variant
Dim Rng As Range

On Error GoTo EndMacro
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual


Set Rng = Application.Intersect(ActiveSheet.UsedRange, _
                    ActiveSheet.Columns(ActiveCell.Column))

Application.StatusBar = "Processing Row: " & Format(Rng.Row, "#,##0")

N = 0
For R = Rng.Rows.Count To 2 Step -1
If R Mod 500 = 0 Then
    Application.StatusBar = "Processing Row: " & Format(R, "#,##0")
End If

V = Rng.Cells(R, 1).Value
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Note that COUNTIF works oddly with a Variant that is equal to vbNullString.
' Rather than pass in the variant, you need to pass in vbNullString explicitly.
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
If V = vbNullString Then
    If Application.WorksheetFunction.CountIf(Rng.Columns(1), vbNullString) > 1 Then
        Rng.Rows(R).EntireRow.Delete
        N = N + 1
    End If
Else
    If Application.WorksheetFunction.CountIf(Rng.Columns(1), V) > 1 Then
        Rng.Rows(R).EntireRow.Delete
        N = N + 1
    End If
End If
Next R

EndMacro:

Application.StatusBar = False
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
MsgBox "Duplicate Rows Deleted: " & CStr(N)

End Sub

DeleteRowOnCell

The macro DeleteBlankRows will delete a row if the entire row is blank.  This macro will delete the entire row if a the cell in the specified column is blank.  Only this column is checked. Other columns are ignored.  This macro was suggested by Dana DeLouis, in the Excel programming newsgroup.  Thanks, Dana !
Public Sub DeleteRowOnCell()

On Error Resume Next
Selection.SpecialCells(xlCellTypeBlanks).EntireRow.Delete
ActiveSheet.UsedRange

End Sub


To use this macro, select a columnar range of cells, and then run the macro.    If the cell in that column is blank, the entire row will be deleted.  To process the entire column, click the column header to select the entire column.

Deleting Blank Rows

The DeleteBlankRows procedure shown below will delete all blank rows in the worksheet specified by the WorksheetName parameter. If this parameter is omitted, the active sheet is used. The procedure will delete rows that are entirely blank or contain cells that have only a single apostrophe (text formatting control character).  The procedure requires the IsRowClear function, shown after the DeleteBlankRows procedure. It will not delete rows that contain formulas, even if that formula returns an empty value. The function will not delete rows that are precedents of a formula in a cell if those precedent rows have lower row number than the row.  For example, if rows 1 to 5 are completely blank, and a formula in A10 references rows 1 to 5, rows 1 to 5 will not be deleted.  However, if a formula refers to a range in higher numbered rows than the cell containing the formula, and those rows are entirely blank, those rows referenced by the formula will be deleted. Therefore, the reference of the formula may be changed as rows above the formula are deleted.
Sub DeleteBlankRows(Optional WorksheetName As Variant)
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' DeleteBlankRows
' This function will delete all blank rows on the worksheet
' named by WorksheetName. This will delete rows that are
' completely blank (every cell = vbNullString) or that have
' cells that contain only an apostrophe (special Text control
' character).
' The code will look at each cell that contains a formula,
' then look at the precedents of that formula, and will not
' delete rows that are a precedent to a formula. This will
' prevent deleting precedents of a formula where those
' precedents are in lower numbered rows than the formula
' (e.g., formula in A10 references A1:A5). If a formula
' references cell that are below (higher row number) the
' last used row (e.g, formula in A10 reference A20:A30 and
' last used row is A15), the refences in the formula will
' be changed due to the deletion of rows above the formula.
'
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

Dim RefColl As Collection
Dim RowNum As Long
Dim Prec As Range
Dim Rng As Range
Dim DeleteRange As Range
Dim LastRow As Long
Dim FormulaCells As Range
Dim Test As Long
Dim WS As Worksheet
Dim PrecCell As Range

If IsMissing(WorksheetName) = True Then
    Set WS = ActiveSheet
Else
    On Error Resume Next
    Set WS = ActiveWorkbook.Worksheets(WorksheetName)
    If Err.Number <> 0 Then
        '''''''''''''''''''''''''''''''
        ' Invalid worksheet name.
        '''''''''''''''''''''''''''''''
        Exit Sub
    End If
End If
    

If Application.WorksheetFunction.CountA(WS.UsedRange.Cells) = 0 Then
    ''''''''''''''''''''''''''''''
    ' Worksheet is blank. Get Out.
    ''''''''''''''''''''''''''''''
    Exit Sub
End If

''''''''''''''''''''''''''''''''''''''
' Find the last used cell on the
' worksheet.
''''''''''''''''''''''''''''''''''''''
Set Rng = WS.Cells.Find(what:="*", after:=WS.Cells(WS.Rows.Count, WS.Columns.Count), lookat:=xlPart, _
    searchorder:=xlByColumns, searchdirection:=xlPrevious, MatchCase:=False)

LastRow = Rng.Row

Set RefColl = New Collection

'''''''''''''''''''''''''''''''''''''
' We go from bottom to top to keep
' the references intact, preventing
' #REF errors.
'''''''''''''''''''''''''''''''''''''
For RowNum = LastRow To 1 Step -1
    Set FormulaCells = Nothing
    If Application.WorksheetFunction.CountA(WS.Rows(RowNum)) = 0 Then
        ''''''''''''''''''''''''''''''''''''
        ' There are no non-blank cells in
        ' row R. See if R is in the RefColl
        ' reference Collection. If not,
        ' add row R to the DeleteRange.
        ''''''''''''''''''''''''''''''''''''
        On Error Resume Next
        Test = RefColl(CStr(RowNum))
        If Err.Number <> 0 Then
            ''''''''''''''''''''''''''
            ' R is not in the RefColl
            ' collection. Add it to
            ' the DeleteRange variable.
            ''''''''''''''''''''''''''
            If DeleteRange Is Nothing Then
                Set DeleteRange = WS.Rows(RowNum)
            Else
                Set DeleteRange = Application.Union(DeleteRange, WS.Rows(RowNum))
            End If
        Else
            ''''''''''''''''''''''''''
            ' R is in the collection.
            ' Do nothing.
            ''''''''''''''''''''''''''
        End If
        On Error GoTo 0
        Err.Clear
    Else
        '''''''''''''''''''''''''''''''''''''
        ' CountA > 0. Find the cells
        ' containing formula, and for
        ' each cell with a formula, find
        ' its precedents. Add the row number
        ' of each precedent to the RefColl
        ' collection.
        '''''''''''''''''''''''''''''''''''''
        If IsRowClear(RowNum:=RowNum) = True Then
            '''''''''''''''''''''''''''''''''
            ' Row contains nothing but blank
            ' cells or cells with only an
            ' apostrophe. Cells that contain
            ' only an apostrophe are counted
            ' by CountA, so we use IsRowClear
            ' to test for only apostrophes.
            ' Test if this row is in the
            ' RefColl collection. If it is
            ' not in the collection, add it
            ' to the DeleteRange.
            '''''''''''''''''''''''''''''''''
            On Error Resume Next
            Test = RefColl(CStr(RowNum))
            If Err.Number = 0 Then
                ''''''''''''''''''''''''''''''''''''''
                ' Row exists in RefColl. That means
                ' a formula is referencing this row.
                ' Do not delete the row.
                ''''''''''''''''''''''''''''''''''''''
            Else
                If DeleteRange Is Nothing Then
                    Set DeleteRange = WS.Rows(RowNum)
                Else
                    Set DeleteRange = Application.Union(DeleteRange, WS.Rows(RowNum))
                End If
            End If
        Else
            On Error Resume Next
            Set FormulaCells = Nothing
            Set FormulaCells = WS.Rows(RowNum).SpecialCells(xlCellTypeFormulas)
            On Error GoTo 0
            If FormulaCells Is Nothing Then
                '''''''''''''''''''''''''
                ' No formulas found. Do
                ' nothing.
                '''''''''''''''''''''''''
            Else
                '''''''''''''''''''''''''''''''''''''''''''''''''''
                ' Formulas found. Loop through the formula
                ' cells, and for each cell, find its precedents
                ' and add the row number of each precedent cell
                ' to the RefColl collection.
                '''''''''''''''''''''''''''''''''''''''''''''''''''
                On Error Resume Next
                For Each Rng In FormulaCells.Cells
                    For Each Prec In Rng.Precedents.Cells
                        RefColl.Add Item:=Prec.Row, key:=CStr(Prec.Row)
                    Next Prec
                Next Rng
                On Error GoTo 0
            End If
        End If
        
    End If
    
    '''''''''''''''''''''''''
    ' Go to the next row,
    ' moving upwards.
    '''''''''''''''''''''''''
Next RowNum


''''''''''''''''''''''''''''''''''''''''''
' If we have rows to delete, delete them.
''''''''''''''''''''''''''''''''''''''''''

If Not DeleteRange Is Nothing Then
    DeleteRange.EntireRow.Delete shift:=xlShiftUp
End If

End Sub
Function IsRowClear(RowNum As Long) As Boolean
''''''''''''''''''''''''''''''''''''''''''''''''''
' IsRowClear
' This procedure returns True if all the cells
' in the row specified by RowNum as empty or
' contains only a "'" character. It returns False
' if the row contains only data or formulas.
''''''''''''''''''''''''''''''''''''''''''''''''''
Dim ColNdx As Long
Dim Rng As Range
ColNdx = 1
Set Rng = Cells(RowNum, ColNdx)
Do Until ColNdx = Columns.Count
    If (Rng.HasFormula = True) Or (Rng.Value <> vbNullString) Then
        IsRowClear = False
        Exit Function
    End If
    Set Rng = Cells(RowNum, ColNdx).End(xlToRight)
    ColNdx = Rng.Column
Loop

IsRowClear = True

End Function

Closing All Inactive Workbooks

This macro will close all of the workbooks, except the active workbook, which will remain open
active.

Public Sub CloseAllInactive()

Dim Wb As Workbook
Dim AWb As String
AWb = ActiveWorkbook.Name

SaveAll
For Each Wb In Workbooks
    If Wb.Name <> AWb Then
        Wb.Close savechanges:=True
    End If
Next Wb
Application.StatusBar = "All Workbooks Closed."

End Sub

Closing All Workbooks

This macro will close all of the workbooks open in Excel.  It requires the SaveAll macro, listed later on this page.

Public Sub CloseAll()

Dim Wb As Workbook
SaveAll
For Each Wb In Workbooks
    If Wb.Name <> ThisWorkbook.Name Then
        Wb.Close savechanges:=True
    End If
Next Wb
ThisWorkbook.Close savechanges:=True

End Sub

Thursday, September 8, 2011

Add tabs to centre of text area and right margin



The following macro sets a centre aligned tab, centred between the current margins, and a right aligned tab at the right margin.
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, _
        Leader:=wdTabLeaderSpaces
End With
End Sub


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