Sub TblHiLite()
Application.ScreenUpdating = False
Dim c As Long, h As Long, n As Long, r As Long, s As Long, w As Long, StrTitle As String, Hdr As Boolean
w = RGB(255, 255, 255)
'Abort if the cursor is not in a table
If Selection.Information(wdWithInTable) = False Then
  MsgBox "The selection is not in a table!", vbOKOnly, "TblHiLite"
  GoTo ErrExit
End If
'Get Parameters
On Error GoTo ErrExit
c = CLng(InputBox("Starting Column?", "TblHiLite"))
If LCase(InputBox("Table has a header row?", "TblHiLite")) = "yes" Then Hdr = True Else Hdr = False
Shading = CLng(InputBox("Colour for Shading? Select # from:" & vbCr & _
  "0: none" & vbCr & _
  "1: pale blue" & vbCr & _
  "2: pale green" & vbCr & _
  "3: pale yellow" & vbCr & _
  "4: pink", "TblHiLite"))
On Error GoTo 0
'Determine the start row, according to whether there's a header
If Hdr = True Then
  n = 3
Else
  n = 2
End If
'Get the applicable colour constant
Select Case s
  Case 1: s = RGB(198, 217, 241)
  Case 2: s = RGB(153, 255, 153)
  Case 3: s = RGB(255, 255, 153)
  Case 4: s = RGB(255, 153, 153)
  Case Else: s = w
End Select
'process the table
With Selection.Tables(1)
  If c > .Columns.Count Then
    MsgBox "There is no column " & c & " in the table!", vbOKOnly, "TblHiLite"
    GoTo ErrExit
  End If
  StrTitle = Split(.Cell(n - 1, c).Range.Text, vbCr)(0)
  .Rows(2).Shading.BackgroundPatternColorIndex = 0
  h = w
  For r = n To .Rows.Count
    If Split(.Cell(r, c).Range.Text, vbCr)(0) <> StrTitle Then
      If h = w Then h = s Else h = w
      StrTitle = Split(.Cell(r, c).Range.Text, vbCr)(0)
    End If
    .Rows(r).Shading.BackgroundPatternColor = h
  Next
End With
ErrExit:
Application.ScreenUpdating = True
End Sub