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

[chaelie2015]

Bonsoir Forum
Je souhaite identifier des doublons distincts dans une colonne B et les colorer individuellement.
Par exemple, dans la plage de cellules B2:B18, j'ai les valeurs suivantes :

- 12
- 13
- 14
- 15
- 12
- 16
- 17
- 13
- 19
- 20
- 21
- 12
- 22
- 13
- 24
- 23
- 14

Je recherche une méthode pour attribuer une couleur unique à chaque doublon différent. Par exemple, dans ce cas,colorer le nombre 12 en jaune, le nombre 13 en bleu et le nombre 14 en rouge, et ainsi de suite pour chaque doublon distinct.
Merci

 

[Eric KERGRESSE]

Bonjour,

Avec une variable dictionnaire. Il vous faut créer une zone nommée pour y définir vos couleurs comme dans le vidage d'écran ci-dessous.

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

 

[job75]

Bonjour chaelie2015, Eric KERGRESSE,

Pour le fun, avec des couleurs aléatoires prises dans la palette des 56 couleurs :

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

On pourrait se préoccuper de la couleur de police mais bof...

A+

 

[patricktoulon]

re
a utiliser les 56 couleurs de la palette couleur excel pas besoins d'un aire couleur
le dico fera toujours la même chose
mais Attenttion cela implique qu'il y ai que 55 possibilités de doublons puis que j'enlève le noir

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

 

[chaelie2015]

Bonjour Eric KERGRESSE, Job75 et le forum

Merci pour vos réponses.​

@ Eric : Je souhaite obtenir des couleurs aléatoires sans définir de zone spécifique, et ajuster la couleur du texte dans la cellule colorée pour qu'elle soit lisible.​

@ Job75 : Je souhaite colorer uniquement les doublons différents.
les restes de cellules ne changent pas la couleur (blanche avec police Noir)
Merci

 

[patricktoulon]

re
tout dabords
ta plage va elle évoluer en terme de taille
si c'est le cas on peut oublier les 56 couleurs natives
essayez de faire des demandes completes quand à l'objectif ,sinon on perd du temps pour rien

 

[chaelie2015]

Re
Le nombre maximum de doublons distincts ne dépasse pas 30
A+

 

[patricktoulon]

ok donc voici une autre version
qui:

1. colore les doublons avec une couleur (unique pour chaque chaine en double)
2. ne colore pas ceux qui ne sont pas en double (les laisse en couleur xlnone)
3. color le font en blanc si la couleur est trop foncée où dite "froide"

tu n'a droit qu'a 55 possibilites de doublons
au delas il y aura une erreur

Option Explicit
Sub ApplyColorDouble()
    Dim p As Range, I&, Dico As Object, X&: X = 1
    Set Dico = CreateObject("scripting.dictionary")
    Set p = Feuil1.Range("B1", Cells(Rows.Count, "B").End(xlUp))
    p.Interior.Color = xlNone
    p.Font.Color = 0
    For I = 1 To p.Cells.Count
        If Application.CountIf(p, Trim(p.Cells(I).Text)) > 1 Then
            If Not Dico.exists(Trim(p.Cells(I).Text)) Then
                X = X + 1: If X = 2 Then X = 3:
                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
        End If
        'visibilité du font en cas de couleur trop foncée on met le font en blanc
        Select Case p.Cells(I).Interior.ColorIndex
        Case 1, 3, 5, 7, 9, 10, 11, 13, 14, 18, 21, 23, 25, 29, 30, 31, 32, 47, 48, 49, 50, 51, 52, 53, 54, 55, 56: p.Cells(I).Font.ColorIndex = 2
        End Select
    Next
End Sub

 

[job75]

Voyez le fichier joint et cette nouvelle macro :

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

54 couleurs de fond sont utilisées.

Les colonnes J et K permettent d'utiliser la couleur de police qui va bien.

A+

 

[patricktoulon]

@job75 on a presque fait la même chose sauf que je n'utilise pas de table

chez toi a chaque lancement les couleurs changent
chez moi elle ne changent pas

 

[mapomme]

Bonjour à tous ,

, et ajuster la couleur du texte dans la cellule colorée pour qu'elle soit lisible.

Voici deux fonctions (au choix) qui retournent une couleur qui permet de distinguer à l’œil (humain) les deux couleurs de l'une par rapport à l'autre (couleur passée en argument par rapport à la couleur retournée par la fonction).

• Les deux fonctions sont : Contraster_NB(xCouleur) et Trancher_NB(xCouleur)
• Elles peuvent donner des résultats légèrement différents (dans le classeur, les différences sont pointées avec une cellule en vert en colonne B)

Le bouton :

• Bleu => applique la fonction Contraster_NB à la colonne A
• Rouge => applique la fonction Trancher_NB à la colonne D
• Marron => réinitialise les couleurs de police à noir pour les colonnes A et D

Le code des deux fonctions dans module1 :

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

 

[chaelie2015]

Bonjour patricktoulon, Job75, le forum
Je vous remercie, les deux options sont parfaites, mais je préfère la proposition de patricktoulon. , qui me convient à mon fichier principal
MERCI