Discussion :

[jpvba]

Bonjour a vous tous,


J'ai un besoin de pouvoir colorer tous les élément dont la valeur se répète plus qu'une fois. J'ai trouvé en fouillant le web un code utilisant le dico que je trouve génial mais je voudrais être en mesure de l'améliorer afin qu'il puisse répondre a mes besoins.

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
Sub couleur_sur_doublons()
  Dim m As Object, i As Long, z
  Set m = CreateObject("Scripting.Dictionary")
  For i = 1 To Cells(Rows.Count, 1).End(xlUp).Row
  z = Cells(i, 1)
  If Not m.Exists(z) Then m.Add z, z Else Cells(i, 1).Interior.ColorIndex = 3
  Next i
 End Sub

Présentement le code utilise une selection, je voudrais pouvoir définir une plage précise, donc la transformer en fonction dont l'argument est un range.. Je regarde les variables mais je bloque a la boucle. Je croyais pouvoir remplacer certaine choses mais il me manque le concecpt de seulement prendre une partie du range pour la couleur. (Je pensais abolir la variable i ...)

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
Function couleur_sur_doublons_test(colonne_voulu As Range)
  
  Dim m As Object, i As Long, z
  Set m = CreateObject("Scripting.Dictionary")
'  For i = 1 To Cells(Rows.Count, 1).End(xlUp).Row
  z = Range(colonne_voulu & 2, colonne_voulu & LastLignUsedInColumn(colonne_voulu))
  If Not m.Exists(z) Then m.Add z, z Else Cells(i, 1).Interior.ColorIndex = 3
'  Next i
 End Function

Autre chose que j'interprete le code c'est que lorsqu'il rencontre une cellule, il peuple le dico, ce qui empeche de colorier la premiere apparence du doublons. Étant donné que je suis novice en dico, Est-ce qu'il y a une facon de peupler en premier le dico et non au fur et a mesure ???



merci de votre aide précieuse !!!

[jpvba]

J'ai trouvé quelquechose apres une heure sur le site de notre ami Jacques Boigontier


hail to the king !!!

[Invité]

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
Sub test()
couleur_sur_doublons_test Range(Range("A1"), Cells(Rows.Count, "A").End(xlUp))
End Sub
Sub couleur_sur_doublons_test(ByRef colonne_voulu As Range)
  With CreateObject("Scripting.Dictionary")
    For Each a In colonne_voulu
       If Not .Exists(a.Value) Then .Add a.Value, a.Value Else a.Interior.ColorIndex = 3
    Next
 End With
 End Sub

[jpvba]

Merci dysorthographie

Avec ta partie de code, je vais pouvoir analyser et comprendre !!!

[jpvba]

Avec le code de Jacques Boigontier j'Arrive a

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
Function doublons_couleur_unique(lettre_colonne_voulue As String)
Dim mondico As Object
Dim c As Variant
 
   Range(lettre_colonne_voulue & 2, lettre_colonne_voulue & LastLignUsedInColumn(lettre_colonne_voulue)).Interior.ColorIndex = xlNone
   Set mondico = CreateObject("Scripting.Dictionary")
   For Each c In Range(lettre_colonne_voulue & 2, lettre_colonne_voulue & LastLignUsedInColumn(lettre_colonne_voulue))
     If c <> "" Then mondico.item(c.value) = mondico.item(c.value) + 1
   Next c
   For Each c In Range(lettre_colonne_voulue & 2, lettre_colonne_voulue & LastLignUsedInColumn(lettre_colonne_voulue))
     If mondico.item(c.value) > 1 Then c.Interior.ColorIndex = 4
   Next c
 End Function

Ton code dysorthographie arrive avec le même probleme initale pour la première occurance d'un doublons (La premiere apparition du doublons n'est pas colorié). Également il considère les cellules vides comme doublons, ce qui est problématique dans mon cas.


Mais je comprends mieux que le code initiale

[Invité]

Bonjour,
C'est la même solution qu'au poste #5 inspiré d'une source de Jacques Boigontier , pour qui j'ai beaucoup de respect.

Je lui reprocher seulement de faire une double passe. Une pour enrichir le dictionnaire et une autre pour actualisé Excel.

Si je j'utilise une requête Sql qui d'une certaine manière fait la même chose, c'est parce que ADO le fait en assembleur et donc plus rapide que VBA.

Certains me dirons qu'ADO ne marche pas sur MAC et je répondrai que les dictionnaire, qui était bien le postulat de départ, non plus.

[SBAY3I]

merci beucoup pour ta reponse, en fait je ne pouvais pas activer le code de poste #5, j'ai taper le nom (doublons_couleur_unique) mais çammarche pas

Bonjour,
C'est la même solution qu'au poste #5 inspiré d'une source de Jacques Boigontier , pour qui j'ai beaucoup de respect.

Je lui reprocher seulement de faire une double passe. Une pour enrichir le dictionnaire et une autre pour actualisé Excel.

Si je j'utilise une requête Sql qui d'une certaine manière fait la même chose, c'est parce que ADO le fait en assembleur et donc plus rapide que VBA.

Certains me dirons qu'ADO ne marche pas sur MAC et je répondrai que les dictionnaire, qui était bien le postulat de départ, non plus.

[Invité]

Désolé mais je ne vois pas l'intérêt de ce code!
Et si je veux le faire sur une autre feuille ou un autre classeur?

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
Sub test()
couleur_sur_doublons_test  "A",3
couleur_sur_doublons_test  "B",4
couleur_sur_doublons_test  "C",5
End Sub
Sub couleur_sur_doublons_test(ByVal col As string,coul as integer )
  With CreateObject("Scripting.Dictionary")
    For Each a In Range(cells(1,col),Cells(Rows.Count, col).End(xlUp))
       if cstr(a.value)<>"" then
            If Not .Exists(a.Value) Then .Add a.Value, a.Value Else a.Interior.ColorIndex = coul
        End If
    Next
 End With
 End Sub

[jpvba]

Char ami,


Dans ma vision et mon champs, ce code est précieux

LE code permet de ne pas utiliser la mise en forme conditionnelle dont les copier / coller de cellules font varier la plage voulues. Dans mon champs d'activité, il se peut qu'un produit X est acheté chez un fournisseur Y, fournisseur Z, etc ... Dans certains cas il se peut que le produit n'est pas toute a fait identique, sois une caractéristique importantes qui est vitale pour une utilisation particulière. Donc il va falloir créé un nouveau produit dans la base de donné. L’autre situation c'Est que le produit est totalement identique peut importe l'endroit qu'il est acheté et les différences sont a peine minimale ou n'existe pas donc les produits est ramené sur le même code de produit.


Donc en résumé le code est un aide a la prise de décisions. Ce que la machine ne peut décidé, il peut au moins aidé à discerner les cas auquel un humain doit absolument tranché.


Dans mon cas je n'ai pas besoins que ce sois sur un autre feuille mais c'est une excellente idée. Je vais essayé de pondre quelquechose !!!


Pour ton code, tu as corrigé le problème des cellules vides, mais étant donné que le dico est remplis encours de route, la première occurrence du doublons n'est toujours pas soulignés. Donc je crois qu'il faut absolument le remplir avant d'effectué la boucle.


Un gros merci dysortho. !!! En espérant que j'ai pu t'éclairé sur l'utilité du code.

[Invité]

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
Sub test()
couleur_sur_doublons_test "A", 3
couleur_sur_doublons_test "B", 4
couleur_sur_doublons_test "C", 5
End Sub
Sub couleur_sur_doublons_test(ByVal col As String, coul As Integer)
Dim cn As Object: Set cn = CreateObject("Adodb.connection")
cn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & ThisWorkbook.FullName & ";Extended Properties=""Excel 12.0;HDR=no;"""
Set rs = cn.Execute("Select count([F1]),[F1] from [Feuil1$" & Replace(Range(Cells(1, col), Cells(Rows.Count, col).End(xlUp)).Address, "$", "") & "] where [F1]  is not null group by [F1] having count([F1])>1")
 
 
'  With CreateObject("Scripting.Dictionary")
    For Each a In Range(Cells(1, col), Cells(Rows.Count, col).End(xlUp))
       If CStr(a.Value) <> "" Then
       rs.Filter = "[F1]='" & Replace(a.Value, "'", "''") & "'"
            If Not rs.EOF Then a.Interior.ColorIndex = coul
        End If
    Next
rs.Close
cn.Close
 End Sub

[jpvba]

Vraiment génial !!!

Ça marche numéro uno !!!!

[jpvba]

J'aurais penser que le code suivant aurais foncitonner, mais je ne sais pas comment peupler la nouvelle feuille. Il y a t-il une façon simple rapide au lieu de copier des valeurs ???

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
Sub test_color()
 test_doublons_couleur_unique ("a")
 End Sub
 
 
 
 
Function test_doublons_couleur_unique(lettre_colonne_voulue As String)
Dim mondico As Object
Dim c As Variant
Dim nouvelle_feuil As String
 
If sheetExists("nouvelle_feuil") = True Then
        Application.DisplayAlerts = False
        Sheets("nouvelle_feuil").Delete
        Application.DisplayAlerts = True
Else
End If
 
 
Worksheets.Add.Name = "nouvelle_feuil"
 
 
   Range(lettre_colonne_voulue & 2, lettre_colonne_voulue & LastLignUsedInColumn(lettre_colonne_voulue)).Interior.ColorIndex = xlNone
   Set mondico = CreateObject("Scripting.Dictionary")
   For Each c In Range(lettre_colonne_voulue & 2, lettre_colonne_voulue & LastLignUsedInColumn(lettre_colonne_voulue))
     If c <> "" Then mondico.item(c.value) = mondico.item(c.value) + 1
   Next c
   For Each c In Range(lettre_colonne_voulue & 2, lettre_colonne_voulue & LastLignUsedInColumn(lettre_colonne_voulue))
     If mondico.item(c.value) > 1 Then Sheets("nouvelle_feuil").Cells(c, 1).value = mondico.item(c.value)
 
   Next c

ou bien

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
Function test_doublons_couleur_unique(lettre_colonne_voulue As String)
Dim mondico As Object
Dim c As Variant
Dim nouvelle_feuil As String
 
If sheetExists("nouvelle_feuil") = True Then
        Application.DisplayAlerts = False
        Sheets("nouvelle_feuil").Delete
        Application.DisplayAlerts = True
Else
End If
 
 
Worksheets.Add.Name = "nouvelle_feuil"
 
 
   Range(lettre_colonne_voulue & 2, lettre_colonne_voulue & LastLignUsedInColumn(lettre_colonne_voulue)).Interior.ColorIndex = xlNone
   Set mondico = CreateObject("Scripting.Dictionary")
   For Each c In Range(lettre_colonne_voulue & 2, lettre_colonne_voulue & LastLignUsedInColumn(lettre_colonne_voulue))
     If c <> "" Then mondico.item(c.value) = mondico.item(c.value) + 1
   Next c
   For Each c In Range(lettre_colonne_voulue & 2, lettre_colonne_voulue & LastLignUsedInColumn(lettre_colonne_voulue))
     If mondico.item(c.value) > 1 Then Sheets("nouvelle_feuil").Cells(c.Row.Count, 1).value = mondico.item(c.value)
 
   Next c

[Invité]

Bonsoir,

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
Adresse="$A$1:$A$10"
"[feuille_voulu$" & replace(Adresse,"$","") & "]"
 
Nom="feuille_voulu"
Adresse = Replace(.Range(.Cells(1, col), .Cells(Rows.Count, col).End(xlUp)).Address, "$", "")
Set rs = .Execute("Select count([F1]),[F1] from [" & Nom & "$" & Adresse & "] where [F1]  is not null group by [F1] having count([F1])>1")

[jpvba]

Donc si j'applique la modification a ce que je veux j'arrive a ce résultats (je n'ai pas fixer l'adresse étant donné que je veux la totalité de la colonne et le nom est égale au paramètre feuille_voulu)

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
Sub feuille_sommaire_doublons_2(ByVal col As String, feuille_voulu As String)
Dim Adresse As String: Adresse = Replace(Range(Cells(1, col), Cells(Rows.Count, col).End(xlUp)).Address, "$", "")
Dim rs As Object
Dim f As Object
Dim wbk_creation As Workbook
 
Set wbk_creation = ActiveWorkbook
 
If sheetExists("sommaire_doublons") = True Then
        Application.DisplayAlerts = False
        Sheets("sommaire_doublons").Delete
        Application.DisplayAlerts = True
End If
 
If Not CBool(InStr(Adresse, ":")) Then Exit Sub
wbk_creation.Sheets(feuille_voulu).Select
With CreateObject("Adodb.connection")
    .Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & wbk_creation.FullName & ";Extended Properties=""Excel 12.0;HDR=no;"""
    Set rs = .Execute("Select count([F1]),[F1] from [" & feuille_voulu & "$" & Adresse & "] where [F1]  is not null group by [F1] having count([F1])>1")
 
If Not rs.EOF Then
    Set f = wbk_creation.Sheets.Add: f.Cells(1, "A").CopyFromRecordset rs
    ActiveSheet.Name = "sommaire_doublons"
 
End If
    rs.Close
    .Close
 
 End With
 
 
End Sub

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
Sub test()
 
feuille_sommaire_doublons_2 "A", "Feuil1"
 
End Sub

La première exécution tous va sur des roulettes !!! La seconde exécution, la feuille sommaire_doublons n'est plus présente (donc elle est détruite mais pas recréé). La 3eme exécution tous marche a merveille, ainsi de suite

La Feuil1 a les données suivantes



La Feuil6 a les données suivants :



Si je parametre la sub test ainsi a fin de faire l'exercise avec la feuille 6

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
Sub test()
 
feuille_sommaire_doublons_2 "A", "Feuil6"
 
End Sub

La première exécution, tous marche comme il se doit, la feuille sommaire_doublons est créés avec 2 a, 2 b, 2 c. La seconde exécution, la feuille sommaire_doublons contient seulement 2 a ... c'Est là que tout est bizzare !!! La 3eme exécution, la feuille sommaire_doublons n'est plus présente. La 4eme exécution le tout est redevenu a la normale



JE me pose plusieurs questions mais je ne commprends pas pourquoi je n'arrive toujours pas au meme résultats.



J'ai essayé a nouveau

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

feuille_sommaire_doublons_2 "A", "Feuil6"

entre chaque exécution, je change de feuille et la tous marche parfaitement


merci encore pour votre aide !!!

[Invité]

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
Sub test()
 
NewFeulle_sur_doublons_test "A"
NewFeulle_sur_doublons_test "B"
NewFeulle_sur_doublons_test "C"
End Sub
Sub NewFeulle_sur_doublons_test(ByVal col As String)
ThisWorkbook.Sheets("Feuil1").Select
With CreateObject("Adodb.connection")
.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & ThisWorkbook.FullName & ";Extended Properties=""Excel 12.0;HDR=no;"""
Set rs = .Execute("Select count([F1]),[F1] from [Feuil1$" & Replace(Range(Cells(1, col), Cells(Rows.Count, col).End(xlUp)).Address, "$", "") & "] where [F1]  is not null group by [F1] having count([F1])>1")
Set f = ThisWorkbook.Sheets.Add: f.Cells(1, "A").CopyFromRecordset rs
rs.Close
.Close
 End With
End Sub

[jpvba]

Il y a un erreur d'exécution '-2147467259 (80004005)':

Cette table contient des cellules hors de la plage de cellules définie dans cette feuille de calcul



Le débogage me pointe sur la ligne

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

Set rs = .Execute("Select count([F1]),[F1] from [Feuil1$" & Replace(Range(Cells(1, col), Cells(Rows.Count, col).End(xlUp)).Address, "$", "") & "] where [F1]  is not null group by [F1] having count([F1])>1")

crime que tu es génial et efficaces ...

[SBAY3I]

merci beucoup pour le sujet, et le site de notre ami Jacques Boigontier

[Invité]

En fait thisworkbook est le fichier qui exécute la macro. Thisworkbook.fullname retourne le chemin complet du fichier qui exécute la macro

J'effectues ma connexion Data Source=" & ThisWorkbook.FullName

Je défis si la.première ligne est le nom.de champs HDR=yes/no;"""

Si no la première colonne de la plage considérée est [F1] la deuxième [F2] [Etc...]

Si yes alors la première ligne est le nom.de chams [Nom],[Pnom],[Etc...]

Une requête est une description

Je sélectionne [F1],[F2] de la Feuille$
Je filtre sur la valeur toto de [F1]
Je regroupe.mes champs [F1],[F2]
Je fait un dixième filtre suis mon regroupement

Le croup by permet de faire de statiques cunt,min,max,moye etc...
Le having des filtre sur ces même statistiques.

Select (chemps)
From table
Where expression
Group by champs
Having expression

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
 
Select count([F1]),[F1],[F2]
From [Feuill1$]
Where [F1]='toto'
Group by [F1],[F2]
Having count([F1])>1
 
Select count([F1]),[F1],[F2],[F3]
From [Feuill1$]
Where [F1]='toto'
Group by [F1],[F2],[F3]
Having count([F1[)>1

[jpvba]

Juste un peu avant la notification du courriel,


J'ai réussis a avoir le bon résultat avec ceci

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
Function feuille_sommaire_doublons(ByVal col As String, feuille_voulu As String)
Dim Adresse As String
Dim rs As Object
Dim f As Object
Dim wbk_creation As Workbook
 
Set wbk_creation = ActiveWorkbook
 
 
If sheetExists("sommaire_doublons") = True Then
        Application.DisplayAlerts = False
        Sheets("sommaire_doublons").Delete
        Application.DisplayAlerts = True
End If
 
Sheets(feuille_voulu).Activate
Adresse = Replace(Range(Cells(1, col), Cells(Rows.Count, col).End(xlUp)).Address, "$", "")
 
 
If Not CBool(InStr(Adresse, ":")) Then Exit Function
 
 
With CreateObject("Adodb.connection")
    .Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & wbk_creation.FullName & ";Extended Properties=""Excel 12.0;HDR=no;"""
    Set rs = .Execute("Select count([F1]),[F1] from [" & feuille_voulu & "$" & Adresse & "] where [F1]  is not null group by [F1] having count([F1])>1")
 
If Not rs.EOF Then
    Set f = wbk_creation.Sheets.Add: f.Cells(1, "A").CopyFromRecordset rs
    ActiveSheet.Name = "sommaire_doublons"
 
End If
    rs.Close
    .Close
 
 End With

l'adresse prenait la valeur de la feuille active.



Je vais également jeter un oeil a votre solution

[Invité]

Bonjour,

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
Sub test()
NewFeulle_sur_doublons_test "A"
couleur_sur_doublons_test "A", 6
End Sub
Sub couleur_sur_doublons_test(ByVal col As String, coul As Integer)
Dim cn As Object, Adresse As String: Set cn = CreateObject("Adodb.connection")
Adresse = Replace(Range(Cells(1, col), Cells(Rows.Count, col).End(xlUp)).Address, "$", "")
If Not CBool(InStr(Adresse, ":")) Then Exit Sub
ThisWorkbook.Sheets("Feuil1").Select
cn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & ThisWorkbook.FullName & ";Extended Properties=""Excel 12.0;HDR=no;"""
Set rs = cn.Execute("Select count([F1]),[F1] from [Feuil1$" & Adresse & "] where [F1]  is not null group by [F1] having count([F1])>1")
    For Each a In Range(Cells(1, col), Cells(Rows.Count, col).End(xlUp))
       If CStr(a.Value) <> "" Then
       rs.Filter = "[F1]='" & Replace(a.Value, "'", "''") & "'"
            If Not rs.EOF Then a.Interior.ColorIndex = coul
        End If
    Next
rs.Close
cn.Close
 End Sub
 
 
Sub NewFeulle_sur_doublons_test(ByVal col As String)
Dim Adresse As String: Adresse = Replace(Range(Cells(1, col), Cells(Rows.Count, col).End(xlUp)).Address, "$", "")
If Not CBool(InStr(Adresse, ":")) Then Exit Sub
ThisWorkbook.Sheets("Feuil1").Select
With CreateObject("Adodb.connection")
    .Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & ThisWorkbook.FullName & ";Extended Properties=""Excel 12.0;HDR=no;"""
    Set rs = .Execute("Select count([F1]),[F1] from [Feuil1$" & Adresse & "] where [F1]  is not null group by [F1] having count([F1])>1")
    Set f = ThisWorkbook.Sheets.Add: f.Cells(1, "A").CopyFromRecordset rs
    rs.Close
    .Close
 End With
End Sub