Discussion :

[jpvba]

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

[laurent_ott]

Bonjour,
Une proposition, qui met en couleur les doublons d'une sélection.

Code VBA :

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
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
Option Explicit
 
'------------------------------------------------------------------------------------------------------
Sub Colorer_Doublons_Sélection()
'------------------------------------------------------------------------------------------------------
Dim TabDonnées() As Variant
Dim i As Long, Couleur As Long, R As Long, G As Long, B As Long
Dim C As Range, Doublon As Variant
 
' Initialise le compteur aléatoire:
Randomize Timer
 
' Dimentionne la variable qui mémorise les données sur le nombre de sélections:
ReDim TabDonnées(0 To Selection.Count - 1)
 
' Boucle sur les sélections pour effacer la couleur de fond et mémoriser la donnée:
For Each C In Selection
    C.Interior.ColorIndex = xlNone
    TabDonnées(i) = C.Value
    i = i + 1
Next C
 
' Trie les données par ordre croissant:
Call QuickSort(TabDonnées(), 0, UBound(TabDonnées()))
 
' Utilisation d'un dictionnaire pour vérifier qu'une couleur n'est pas déjà utilisée:
Dim Dict As Object
Set Dict = CreateObject("Scripting.Dictionary")
 
' Boucle sur les données mémorisées:
For i = 0 To UBound(TabDonnées()) - 1
 
    ' Si la donnée et égale à la suivante (c'est donc un doublon)
    ' et que le doublon n'a pas déjà été traité:
    If TabDonnées(i) = TabDonnées(i + 1) And TabDonnées(i) <> Doublon Then
        ' Prend une couleur au hasard:
        Do
            R = 100 + Rnd * 135: G = 150 + Rnd * 105: B = 100 + Rnd * 155
            Couleur = RGB(R, G, B)
            If Dict.Exists(Couleur) = False Then ' Si elle n'est pas déjà utilisée.
                Dict.Add Couleur, Null           ' Mémorise la couleur.
                Exit Do                          ' Sort de la boucle.
            End If
        Loop
        ' Boucle sur la sélection pour mettre le fond en couleur si
        ' la donnée correspond à la valeur de référence:
        For Each C In Selection
            If C.Value = TabDonnées(i) Then C.Interior.Color = Couleur
        Next C
    End If
 
    ' Mémorise le doublon traité:
    Doublon = TabDonnées(i)
 
Next i
 
End Sub
 
'----------------------------------------------------------------------------------------
Private Sub QuickSort(ByRef TabDonnées() As Variant, ByVal Gauche As Long, ByVal Droite As Long)
'----------------------------------------------------------------------------------------
Dim i As Long, j As Long, Temp As Variant, Pivot As Variant
 
i = Gauche
j = Droite
Pivot = TabDonnées((Gauche + Droite) / 2)
 
Do
    While Pivot > TabDonnées(i): i = i + 1: Wend
    While TabDonnées(j) > Pivot: j = j - 1: Wend
 
    If j + 1 > i Then
        Temp = TabDonnées(i)
        TabDonnées(i) = TabDonnées(j)
        TabDonnées(j) = Temp
        j = j - 1: i = i + 1
    End If
 
Loop Until i > j
 
If Gauche < j Then Call QuickSort(TabDonnées(), Gauche, j)
If i < Droite Then Call QuickSort(TabDonnées(), i, Droite)
 
End Sub
'------------------------------------------------------------------------------------------------------
'------------------------------------------------------------------------------------------------------

Bonne continuation.

[jpvba]

Merci monsieur Ott,


c'est la perfection !!!


C'Est plus intelligent et rapide que ce qu'ai j'ai pu avoir les IA ... et fonctionnel comparativement à ce que j'ai eu

[laurent_ott]

Bonjour,
J'ai testé le code que j'avais présenté sur de nombreuses sélections et ça rame. Car il y a une boucle sur chaque sélection a chaque nouveau doublon, soit une complexité de n x (n/2).
J'ai donc revu ma copie...
Le principe : je mémorise les doublons, et les couleurs qui leur correspond.
Puis je boucle sur chaque valeur de la sélection pour vérifier s'il s'agit d'un doublon et dans ce cas j'applique la couleur du doublon. Soit une complexité de n.

Code VBA :

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
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
'------------------------------------------------------------------------------------------------------
Sub Colorer_Doublons_Sélection()
'------------------------------------------------------------------------------------------------------
Dim i As Long, Couleur As Long, R As Long, G As Long, B As Long
Dim C As Range, Doublon As Variant
 
' Utilisation d'une ArrayList pour mémoriser les données:
Dim TabDonnées As Object
Set TabDonnées = CreateObject("System.Collections.ArrayList")
 
' Initialise le compteur aléatoire:
Randomize Timer
 
' Bloque les mises à jour écran pour accélerer les traitements:
Application.ScreenUpdating = False
 
' Boucle sur les sélections pour effacer la couleur de fond et mémoriser la donnée:
For Each C In Selection
    C.Interior.ColorIndex = xlNone
    TabDonnées.Add C.Value
Next C
 
' Trie les données par ordre croissant:
TabDonnées.Sort
 
' Utilisation d'une ArrayList pour mémoriser les couleurs utilisées:
Dim ListCouleur As Object
Set ListCouleur = CreateObject("System.Collections.ArrayList")
' Utilisation d'une ArrayList pour mémoriser les doublons repérés:
Dim ListDoublon As Object
Set ListDoublon = CreateObject("System.Collections.ArrayList")
 
' Boucle sur les données mémorisées (sauf le dernier élément):
For i = 0 To TabDonnées.Count - 1 - 1
 
    ' Si la donnée et égale à la suivante (c'est donc un doublon)
    ' et que le doublon n'a pas déjà été traité:
    If TabDonnées.Item(i) = TabDonnées.Item(i + 1) And TabDonnées.Item(i) <> Doublon Then
        ' Prend une couleur au hasard:
        Do
            R = 100 + Rnd * 135: G = 150 + Rnd * 105: B = 100 + Rnd * 155
            Couleur = RGB(R, G, B)
            If ListCouleur.Contains(Couleur) = False Then  ' Si elle n'est pas déjà utilisée.
                ListCouleur.Add Couleur                    ' Mémorise la couleur.
                ListDoublon.Add TabDonnées.Item(i)         ' Mémorise le doublon.
                Exit Do                                    ' Sort de la boucle.
            End If
        Loop
    End If
 
    ' Mémorise le doublon traité:
    Doublon = TabDonnées.Item(i)
 
Next i
 
' Boucle sur la sélection pour mettre le fond en couleur si
' la donnée correspond un doublon repéré:
For Each C In Selection
    ' Si la donnée est dans la liste de doublon renvoie son indexation dans l'ArrayList
    ' ou renvoi -1 si ce n'est pas un doublon:
    i = ListDoublon.indexOf(C.Value, 0)
    ' Si c'est un doublon alors utilise l'index de la couleur:
    If i >= 0 Then C.Interior.Color = ListCouleur.Item(i)
Next C
 
' Actualise l'écran:
Application.ScreenUpdating = True
 
End Sub
'------------------------------------------------------------------------------------------------------
'------------------------------------------------------------------------------------------------------

Remarque : j'utilise des objets "ArrayList" car je trouve cela plus pratique que les objets "Dictionary". Plus d'info ici

Cordialement.

[jpvba]

C'Est nettement plus rapide ..


J'ai également trouver ceci qui semble être encore plus rapide

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
53
54
55
56
57
58
59
60
61
62
63
Sub test1()
 
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 Cle As String
Dim Couleur As Long
 
Dim start As Single
Dim finish As Single
 
 
    start = Timer
 
Application.ScreenUpdating = False
 
   Set MonDico = CreateObject("Scripting.Dictionary")
 
   ' Première boucle pour compter les occurrences
   For Each C In Selection
     If C <> "" Then
        If Not MonDico.Exists(C.Value) Then
            MonDico.Add C.Value, 1
        Else
            MonDico(C.Value) = MonDico(C.Value) + 1
        End If
     End If
   Next C
 
   ' Deuxième boucle pour générer les couleurs aléatoires pour les valeurs en double
   For Each C In Selection
     If C <> "" And MonDico(C.Value) > 1 Then
        If Not MonDico.Exists(C.Value & "Color") Then
            Randomize
            R = 100 + (Round(Rnd * 155))
            G = 100 + (Round(Rnd * 155))
            B = 100 + (Round(Rnd * 155))
            Couleur = RGB(R, G, B)
            MonDico.Add C.Value & "Color", Couleur
        End If
     End If
   Next C
 
   ' Troisième boucle pour appliquer les couleurs
   For Each C In Selection
    If C <> "" And MonDico(C.Value) > 1 Then
        C.Interior.Color = MonDico(C.Value & "Color")
    Else
        C.Interior.ColorIndex = xlNone ' Les valeurs uniques restent sans couleur
    End If
   Next C
 
Application.ScreenUpdating = True
 
 
finish = Timer
MsgBox "durée du traitement: " & finish - start & " secondes"
 
 
End Sub

merci encore