Guru do Excel e Power BI

Sub PintaDuplicados()
 Dim x As Long, s As Range, frst As String, c As Long
  [B:B].Interior.ColorIndex = xlNone
  For x = 3 To Cells(Rows.Count, 2).End(3).Row
   If Application.CountIf([B:B], Cells(x, 2)) > 1 Then
    If Cells(x, 2).Interior.ColorIndex = xlNone Then
     Set s = [B:B].Find(Cells(x, 2), Lookat:=xlWhole)
     If Not s Is Nothing Then
      frst = s.Address
      Do
       s.Interior.ColorIndex = c + 33
       Set s = [B:B].FindNext(s)
      Loop While Not s Is Nothing And s.Address <> frst
     End If
    End If
    c = c + 1
   End If
  Next x
End Sub