Option Explicit
Sub FirstAndEnd()
Dim Rng As Range, sRng As Range, Clls As Range
Dim eRw As Long, Jj As Long
Dim Color_ As Byte, Lap As Integer
Set Rng = Range([I5], [I65500].End(xlUp)): Lap = 1
eRw = Rng.Rows.Count: Color_ = 34
[g6].CurrentRegion.Interior.ColorIndex = 0
For Each Clls In [g6].Resize(eRw)
If Clls.Value <> "" Then
Set sRng = Rng.Find(Clls.Value, , xlFormulas, xlWhole)
If Not sRng Is Nothing Then
If Clls.Offset(, 2).Value = sRng.Offset(, -2).Value Then
sRng.Offset(, -2).Resize(, Lap).Interior.ColorIndex = Color_
Clls.Resize(, Lap).Interior.ColorIndex = Color_
Color_ = 1 + Color_
If Color_ > 41 Then
Color_ = 34: Lap = 1 + Lap
End If: End If
End If
End If
Next Clls
End Sub