XL 2013 (RESOLU) Couleur unique à chaque doublon différent

Sub CouleursDoublons()

Dim D1 As Object
Dim Liste1 As Variant, Liste2 As Variant
Dim I As Integer, J  As Integer, Couleur As Integer
Dim AireValeurs As Range, AireCouleurs As Range

  Set D1 = CreateObject("Scripting.Dictionary")
  With ActiveSheet
       Set AireValeurs = .Range("B2:B18")
       Set AireCouleurs = Range("CouleursListe")
 End With
 
  AireValeurs.Interior.Color = xlNone
  For I = 1 To AireValeurs.Count
      If Not D1.Exists(CStr(AireValeurs(I))) Then D1.Add CStr(AireValeurs(I)), WorksheetFunction.CountIf(AireValeurs, AireValeurs(I))
  Next I
   
  Liste1 = D1.Keys: Liste2 = D1.Items
  Couleur = 0
  Debug.Print UBound(Liste1)
  For I = LBound(Liste1) To UBound(Liste1)
      If Liste2(I) > 1 Then Couleur = Couleur + 1
      For J = 1 To AireValeurs.Count
          If CStr(Liste1(I)) = CStr(AireValeurs(J)) And Liste2(I) > 1 Then
             AireValeurs(J).Interior.Color = AireCouleurs(Couleur).Interior.Color
          End If
      Next J
  Next I
 
  Set D1 = Nothing: Set AireValeurs = Nothing: Set AireCouleurs = Nothing
 
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
Dim d As Object, c As Range, x$, r, a
Set d = CreateObject("Scripting.Dictionary")
For Each c In [B3].CurrentRegion
    If d.Count = 56 Then Exit Sub
    x = CStr(c)
    If Not d.exists(x) Then
        Do
            r = Application.RandBetween(1, 56)
            If d.Count Then a = d.items
        Loop While IsNumeric(Application.Match(r, a, 0))
        d(x) = r
    End If
    c.Interior.ColorIndex = d(x)
Next
End Sub

Sub test()
    Dim p As Range, I&, Dico As Object, X&
    
    Set Dico = CreateObject("scripting.dictionary")
    
    Set p = Feuil1.Range("A1", Cells(Rows.Count, "A").End(xlUp))
    
    p.Interior.Color = xlNone
    
    X = 1

    For I = 1 To p.Cells.Count
        
        If Not Dico.exists(Trim(p.Cells(I).Text)) Then
            
            X = X + 1: Dico(Trim(p.Cells(I).Value)) = X
            
            p.Cells(I).Interior.ColorIndex = X
        
        Else
            
            p.Cells(I).Interior.ColorIndex = Val(Dico(Trim(p.Cells(I).Text)))
        End If
    Next
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
Dim d As Object, P As Range, c As Range, x$, r, a
Set d = CreateObject("Scripting.Dictionary")
Set P = [B3].CurrentRegion 'à adapter
P.Interior.ColorIndex = xlNone
P.Font.ColorIndex = 1
For Each c In P
    If d.Count = 54 Then Exit Sub 'sécurité
    x = CStr(c)
    If Not d.exists(x) And Application.CountIf(P, c) > 1 Then
        Do
            r = Application.RandBetween(3, 56)
            If d.Count Then a = d.items
        Loop While IsNumeric(Application.Match(r, a, 0))
        d(x) = r
    End If
    If d(x) Then
        c.Interior.ColorIndex = d(x)
        c.Font.ColorIndex = Application.VLookup(d(x), Columns("J:K"), 2, 0)
    End If
Next
End Sub

Function Contraster_NB(xCouleur)
Dim LuminanceApparente#, R&, G&, B&
   R = (xCouleur Mod 256): G = (xCouleur \ 256) Mod 256: B = (xCouleur \ 65536) Mod 256
   LuminanceApparente = 1# - (0.299 * R + 0.587 * G + 0.114 * G) / 255#
   Contraster_NB = IIf(LuminanceApparente < 0.49, vbBlack, vbWhite) 'ou (< 0.5)
End Function

Function Trancher_NB(xCouleur)
   Trancher_NB = IIf(Int(xCouleur / 256) Mod 256 > 128, vbBlack, vbWhite)
End Function