Sub Demo1()
Dim Rd As Range, Rc As Range, R&
[A1].CurrentRegion.Columns("F:G").Interior.ColorIndex = xlNone
With Range([G1].End(xlDown), Cells(Rows.Count, 7).End(xlUp))
For Each Rd In Range("F2", [F1].End(xlDown))
Set Rc = .Find(Rd.Value, , xlValues, xlWhole)
If Not Rc Is Nothing Then
R = Rc.Row
Do
If Rc.Interior.ColorIndex = xlNone Then
Union(Rc, Rd).Interior.ColorIndex = 40
Exit Do
Else
Set Rc = .FindNext(Rc)
End If
Loop Until Rc.Row = R
End If
Next
End With
Set Rc = Nothing
End Sub