Microsoft 365 [Résolu] Couleurs doublons multiple

Private Sub Worksheet_Change(ByVal Target As Range)
Dim coulfond, coulpolice, ncoul%, d As Object, P As Range, c As Range, x$, n%, nn%
coulfond = Array(vbBlack, vbRed, vbGreen, vbYellow, vbBlue, vbMagenta, vbCyan) 'à adapter
coulpolice = Array(vbWhite, vbWhite, vbBlack, vbBlack, vbWhite, vbBlack, vbBlack) 'à adapter
ncoul = UBound(coulfond) + 1
Set d = CreateObject("Scripting.Dictionary")
d.CompareMode = vbTextCompare 'la casse est ignorée
Set P = UsedRange
Application.ScreenUpdating = False
P.Interior.ColorIndex = xlNone 'RAZ
P.Font.ColorIndex = xlAutomatic 'RAZ
For Each c In P
    If c <> "" Then
        x = CStr(c)
        If Not d.exists(x) Then If Application.CountIf(P, c) > 1 Then n = n + 1: d(x) = n
        nn = d(x)
        If nn > 0 And nn <= ncoul Then
            c.Interior.Color = coulfond(nn - 1)
            c.Font.Color = coulpolice(nn - 1)
        End If
    End If
Next
End Sub

    If c <> "" Then
        x = CStr(c)
        If Not d.exists(x) Then n = n + 1: d(x) = n
        nn = d(x)
        If nn <= ncoul Then
            c.Interior.Color = coulfond(nn - 1)
            c.Font.Color = coulpolice(nn - 1)
        End If
    End If