P.S.Чтобы наступила смерть - необходима жизненная сила !!!  

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Dim strStartAddr As String ' Хранит координаты первого найденного _значения
   cvet =  3  'цвет ячейки, исключаем белый и черный
   Var =  1   '№ варианта для отражения в столбце "А"
   Dim rgResult As Range
   'ищем последнюю строку
   ps = Right(ActiveCell.SpecialCells(xlLastCell).Address, Len(ActiveCell.SpecialCells(xlLastCell).Address) -  3 ) +  1 
i =  2 
j =  6 
 
l: If i +  1  >= ps Then GoTo endd
Address = ActiveCell()
 If IsNumeric(Address) = False And IsNumeric(Right(Cells(i, j),  4 )) = False Then
 Address = Cells(i, j)
 End If
' Range(Address).Activate
 If Address = "" Or ActiveCell = "" Then GoTo l1
 strFindData = Address
 Range("a" & ActiveCell.Row) = Var
 P = "h" & ps
   ' Поиск первого входжения искомого слова
   Set rgResult = Range("B2:" & P).Find(strFindData, , xlValues)
   If Not rgResult Is Nothing Then
      ' Сохраним адрес найденной ячейки (чтобы контролировать зацикливание поиска)
      strStartAddr = rgResult.Address
       End If
   Do While Not rgResult Is Nothing
      ' Обработка результата поиска
      rgResult.Select
      If cvet =  57  Then ' если кончались цвета, начинаем заново
      cvet =  3 
      End If
      rgResult.Interior.ColorIndex = cvet ' красим ячейку для нагдядности
Range("a" & rgResult.Row) = Var ' отмечаем № варианта
      ' Новый поиск
      Set rgResult = Range("B2:" & P).FindNext(rgResult)
      If rgResult.Address = strStartAddr Then
            rgResult.Select
      rgResult.Interior.ColorIndex =  2 
Range("a" & rgResult.Row) = ""
             ' Поиск завершен
         Exit Do
      End If
    Loop
   cvet = cvet +  1 
   Var = Var +  1 
l1:
i = i +  1 
   GoTo l
endd:
End Sub