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

chaelie2015

XLDnaute Accro
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
 
Solution
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
VB:
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...

Eric KERGRESSE

XLDnaute Occasionnel
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.

VB:
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


Capture.JPG
 

job75

XLDnaute Barbatruc
Bonjour chaelie2015, Eric KERGRESSE,

Pour le fun, avec des couleurs aléatoires prises dans la palette des 56 couleurs :
VB:
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+
 

Pièces jointes

  • Doublons.xlsm
    15.7 KB · Affichages: 5

patricktoulon

XLDnaute Barbatruc
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
VB:
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

XLDnaute Accro
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
 

Pièces jointes

  • Doublons.xlsm
    17.3 KB · Affichages: 1
Dernière édition:

patricktoulon

XLDnaute Barbatruc
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
VB:
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

demo.gif
 
Dernière édition:

job75

XLDnaute Barbatruc
Voyez le fichier joint et cette nouvelle macro :
VB:
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+
 

Pièces jointes

  • Doublons(1).xlsm
    19.6 KB · Affichages: 6

mapomme

XLDnaute Barbatruc
Supporter XLD
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 :
VB:
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
 

Pièces jointes

  • chaelie2015- couleurs contrastées- v1.xlsm
    22.7 KB · Affichages: 6

Discussions similaires

Statistiques des forums

Discussions
315 093
Messages
2 116 125
Membres
112 666
dernier inscrit
Coco0505