Bonjour à vous,

Je suis présentement en train de faire du "fine tuning" sur certains codes que j'ai. J'ai un code permettant d'identifier les doublons d'une sélections en utilisant un array mais celui-ci est limiter aux nombres d'éléments et j'ai un autre code permettant de colorer de façon aléatoire dans une feuille les doublons en considérant 2 éléments (2 colonnes). Les codes en question contiennent des dictionnaires, ce que je ne maîtrise pas encore mais que je comprends la logique.

Le but de mon exercice est d'identifier les doublons dans une selection (code 1) et de remplacer le array par une couleur aléatoire (code 2)


Je suis présentement bloqué totalement. Je réussis de colorer de façon aléatoire les doublons mais chaque élément double (ou multiple) a une couleur différente, ce qui ne permet pas de bien cibler les donnés multiples.

Il me manque de dire de colorer cette même valeur avant d'aller dans une données suivante


Si vous avez des pistes de solution pouvant m'aider, c'est très apprécier.


merci d'avance !!!!


Voici le premier code (selui de la selection avec le array de couleur

Code : Sélectionner tout - Visualiser dans une fenêtre à part
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
Sub testdoublons_couleur_groupe_selection()
Dim couleurs As Variant
Dim MonDico As Object
Dim C As Variant
Dim x As Variant
Dim nocoul As Variant
 
 
   couleurs = Array(3, 4, 6, 7, 8, 9, 14, 15, 16, 17, 18, 19, 20, 22, 23, 24, 26, 27, 28, 31, 33, 34, 35, 36, 37, 38, 39, 40, _
   41, 42, 43, 44, 45, 46, 47, 48, 50, 53, 54)
 
    For Each x In Selection
 
    x.Interior.ColorIndex = xlNone
 
    Next x
 
   Set MonDico = CreateObject("Scripting.Dictionary")
 
   For Each C In Selection
     If C <> "" Then MonDico.item(C.Value) = MonDico.item(C.Value) + 1
   Next C
 
   For Each C In Selection
    If C <> "" Then
      nocoul = (Application.Match(C.Value, MonDico.keys, 0)) Mod UBound(couleurs)
      If MonDico.item(C.Value) > 1 Then C.Interior.ColorIndex = couleurs(nocoul)
    End If
   Next C
 End Sub
Le second code (sur une feuille selon 2 colonnes)


Code : Sélectionner tout - Visualiser dans une fenêtre à part
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
Sub testdoublons_sur_2_colonnes(ByVal Feuille As String, ByVal Deb As String, ByVal Fin As String)  'Nom de la feuille || 1ère Col || 2ème Col" (pour doublons)
Dim DLig As Long, Rg As Range, VA, C, Coll As New Collection, Cle As String, i As Long, l As String, Doublon, lig
Dim Coll_Coul As New Collection, R As Byte, G As Byte, B As Byte, FT As Boolean
Dim element As Variant
 
    With Sheets(Feuille)
        DLig = .Range(Deb & .Rows.Count).End(xlUp).Row
        C = Array(.Columns(Deb).Count, .Columns(Deb & ":" & Fin).Count)
        .Range(Deb & 2 & ":" & Deb & DLig).Interior.Color = xlNone
 
    For Each element In Union(.Range(Fin & 2 & ":" & Fin & DLig), .Range(Deb & 2 & ":" & Deb & DLig))
        element.Value = CleanTrim(element.Value)
 
        If Len(element.Value) > 255 Then
            MsgBox "au moins une description a plus de 255 caractères limites de excel pour la mémoire", vbCritical
            Exit Sub
        End If
 
    Next element
 
        VA = Application.Index(.Range(Deb & 1 & ":" & Fin & DLig).Value, Evaluate("ROW(1:" & DLig & ")"), C)
 
On Error Resume Next ' --------------------------------------------------------------------------------------------------------------
            For i = 2 To UBound(VA)
                Cle = VA(i, 1) & VA(i, 2)
                Coll.Add i, Cle
                If Err Then Err.Clear: l = Coll(Cle): Coll.Remove Cle: Coll.Add l & "|" & i, Cle
            Next
        i = 0
        Application.ScreenUpdating = False
            For Each Doublon In Coll
                If InStr(Doublon, "|") > 0 Then
                    i = i + 1
                    For Each lig In Split(Doublon, "|")
                        If Rg Is Nothing Then Set Rg = .Range(Deb & lig) Else Set Rg = Union(Rg, .Range(Deb & lig))
                    Next
                    FT = False
                    Do
                        Randomize
                        R = 100 + (Round(Rnd * 135)): G = 150 + (Round(Rnd * 105)): B = 100 + (Round(Rnd * 155)):
                        Cle = R & "  |  " & G & "  |  " & B:        Coll_Coul.Add Cle, Cle
                        If Not Err Then FT = True Else Err.Clear
                    Loop Until FT = True
                    Rg.Interior.Color = RGB(R, G, B)
                End If
                Set Rg = Nothing
            Next
        Application.ScreenUpdating = True
On Error GoTo 0 ' -------------------------------------------------------------------------------------------------------------------
    End With
    Set Coll = Nothing:     Set Coll_Coul = Nothing
End Sub

Voici le code auquel je suis rendu et bloqué

Code : Sélectionner tout - Visualiser dans une fenêtre à part
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
Sub test()
 
Dim MonDico As Object
Dim C As Variant
Dim Coll_Coul As New Collection
Dim R As Byte
Dim G As Byte
Dim B As Byte
Dim FT As Boolean
Dim Cle As String
 
 
   Set MonDico = CreateObject("Scripting.Dictionary")
 
   For Each C In Selection
     If C <> "" Then MonDico.item(C.Value) = MonDico.item(C.Value) + 1
   Next C
 
   For Each C In Selection
    If C <> "" Then C.Interior.ColorIndex = xlNone
 
 
    If MonDico.item(C.Value) > 1 Then
 
    FT = False
      Do
        Randomize
        R = 100 + (Round(Rnd * 135)): G = 150 + (Round(Rnd * 105)): B = 100 + (Round(Rnd * 155)):
        Cle = R & "  |  " & G & "  |  " & B:        Coll_Coul.Add Cle, Cle
        If Not Err Then FT = True Else Err.Clear
      Loop Until FT = True
      C.Interior.Color = RGB(R, G, B)
 
 
 
    End If
 
 Next C
 
 End Sub