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é]

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é]

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é]

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

[jpvba]

WOW tes deux code sont efficaces.

chapeau cher ami !!!

Étant donné que je stock mes macros dans le personnal.xlsb, je vais parcontre triché un peu pour que le code sois exécuté dans la feuille et non la feuille caché.

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
Sub test()
NewFeulle_sur_doublons_test "A"
couleur_sur_doublons_test "A", 8
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")
Dim rs As Object
Dim a As Variant
Dim wbk_creation As Workbook
 
Set wbk_creation = ActiveWorkbook
 
 
 
Adresse = Replace(Range(Cells(1, col), Cells(Rows.Count, col).End(xlUp)).Address, "$", "")
If Not CBool(InStr(Adresse, ":")) Then Exit Sub
wbk_creation.Sheets("Feuil1").Select
cn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & wbk_creation.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, "$", "")
Dim rs As Object
Dim f As Object
Dim wbk_creation As Workbook
 
Set wbk_creation = ActiveWorkbook
 
 
If Not CBool(InStr(Adresse, ":")) Then Exit Sub
wbk_creation.Sheets("Feuil1").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 [Feuil1$" & Adresse & "] where [F1]  is not null group by [F1] having count([F1])>1")
    Set f = wbk_creation.Sheets.Add: f.Cells(1, "A").CopyFromRecordset rs
    rs.Close
    .Close
 End With
End Sub

L'astuce le plus simple c'est de donné un nom a l'activeworkbook et l'utilisé comme référence.

Merci mille fois !!!!

[jpvba]

Il manque une possibilité pour la

NewFeulle_sur_doublons_test


SI il n'y a pas de doublons, la feuille se crée quand même. Il faudrait mettre un "If" possiblement afin d'éviter la création ou un message dans la cellule disant "aucun doublons trouver sur la feuille".



Vraiment pédagogique !!!

si l'ordonnancement est

Code :

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

1
2
3
4
5
6
Sub test()
 
NewFeulle_sur_doublons_test "A"
couleur_sur_doublons_test "A", 6
 
End Sub

La couleur ne se fait pas mais si je fais l'inverse, le tout fonctionne


en espérant le tous pourra également être utile un jour a d'autre personne du forum.



Merci pour ton partage de talent dysorthographie !!!!

[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
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")
If not rs.eof then
    Set f = ThisWorkbook.Sheets.Add: f.Cells(1, "A").CopyFromRecordset rs
End if
    rs.Close
    .Close
 End With
End Sub

[jpvba]

Étant donné l'exécution via access, je ne peux mettre un parametre suplémentaire soir un nom de feuille

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
Sub feuille_sommaire_doublons_test(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.name)" & 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

La ligne suivante comment l'écrire ???

Code :

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

Set rs = .Execute("Select count([F1]),[F1] from [(feuille_voulu.name)" & Adresse & "] where [F1]  is not null group by [F1] having count([F1])>1")

apres, cela je ne crois plus qu'il y est de possibilité et cela couvre tout les besoins futures des visiteur et membres du forum !!!

[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
 With CreateObject("Excel.Application")
    .Visible = True
    With .Workbooks.Open("C:\Users\dysorthographie\Desktop\dysorthographie.xls")
             If .sheetExists("sommaire_doublons") = True Then
            .Application.DisplayAlerts = False
            .Sheets("sommaire_doublons").Delete
            .Application.DisplayAlerts = True
        End If
        With .Sheets(feuille_voulu)
            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
            .Select
            With CreateObject("Adodb.connection")
                .Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & .Parent.FullName & ";Extended Properties=""Excel 12.0;HDR=no;"""
                Set rs = .Execute("Select count([F1]),[F1] from [" & .Name & "$" & Adresse & "] where [F1]  is not null group by [F1] having count([F1])>1")
                If Not rs.EOF Then
                    Set f = .Parent.Sheets.Add: f.Cells(1, "A").CopyFromRecordset rs
                End If
                rs.Close
                .Close
            End With
        End With
        .Save
        .Close False
    End With
    .Quit
End With

Mais si tu à défini une macro dans Excel tu peux tout simplement exécuter dans Access.

Code simple :

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

1
2
3
4
 
With  .Workbooks.Open("C:\Users\dysorthographie\Desktop\dysorthographie.xls")
             .application.run "MyMacro"
End with

Maintenant tu as besoin de communique entre Access et Excel.

Code avec paramètres :

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

1
2
3
4
 
With  .Workbooks.Open("C:\Users\dysorthographie\Desktop\dysorthographie.xls")
             .application.run "NewFeulle_sur_doublons_test","A"
End with

Tu attends un résultat.

Code avec retour :

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

1
2
3
4
5
 
With  .Workbooks.Open("C:\Users\dysorthographie\Desktop\dysorthographie.xls")
Param1="toto":Param2="titi"
             résultat=.application.run( "MyFonction",param1,parm2)
End with

[SBAY3I]

salut a tous
merci beucoup pour le sujet, j'ai une autre cas et je veux la solution s'il vous plait