Sub Test2()
For Each xCell In Range("B2:B19")
xVal1 = xCell.Value
xAd1 = xCell.Address
xVal2 = xCell.Offset(1, 0).Value
xAd2 = xCell.Offset(1, 0).Address
If xVal1 = xVal2 Then
xCpt = xCpt + 1
Select Case xCpt
Case Is = 1
xTmp = xAd1
Case Is = 2
Range(xTmp & ":" & xAd2).Interior.ColorIndex = 3
End Select
Else
xCpt = 0
End If
Next xCell
End Sub