Option Explicit
[B]Sub SoTrung()[/B]
Dim Sh As Worksheet, Rng As Range, sRng As Range, Clls As Range
Dim MyColor As Byte
Sheet1.Select: Set Sh = Sheet2
[B1].CurrentRegion.Offset(1).Interior.ColorIndex = 0
Sh.Cells.Interior.ColorIndex = 0
Set Rng = Sh.Range("B1:B" & Sh.[B65500].End(xlUp).Row)
For Each Clls In Range("B2:B" & [B65500].End(xlUp).Row)
Set sRng = Rng.Find(Clls.Value, , xlFormulas, xlWhole)
If Not sRng Is Nothing Then
MyColor = 34 + (sRng.Row Mod 6)
Clls.Resize(, 2).Interior.ColorIndex = MyColor
sRng.Resize(, 2).Interior.ColorIndex = MyColor
End If
Next Clls
MyColor = [B1].Interior.ColorIndex + 1
[B1].Interior.ColorIndex = IIf(MyColor > 41, 34, MyColor)
[B]End Sub[/B]