Sub FindDups ()
   '
   ' NOTE: You must select the first cell in the column and
   ' make sure that the column is sorted before running this macro
   '
   ScreenUpdating = False
   FirstItem = ActiveCell.Value
   SecondItem = ActiveCell.Offset(1, 0).Value
   Offsetcount = 1
   Do While ActiveCell <> ""
      If FirstItem = SecondItem Then
        ActiveCell.Offset(Offsetcount,0).Interior.Color = RGB(255,0,0)
        Offsetcount = Offsetcount + 1
        SecondItem = ActiveCell.Offset(Offsetcount, 0).Value
      Else
        ActiveCell.Offset(Offsetcount, 0).Select
        FirstItem = ActiveCell.Value
        SecondItem = ActiveCell.Offset(1,0).Value
        Offsetcount = 1
      End If
   Loop
   ScreenUpdating = True
End Sub