XL 2016 copie de doublons sur nouvel onglet

finarobert

XLDnaute Nouveau
Supporter XLD
Bonjour à tous
je possède un fichier excel avec deux onglets(voir fichier joint) : un onglet "résultats" qui est un grand tableau à nombre de lignes et de colonnes variables. J'ai une macro qui met en couleur les doublons de ce tableau. Le bouton de cette macro est en U5.
Ensuite manuellement je recopie dans l'onglet "doublons" tous ces noms de doublons avec, à coté, dans les colonnes adjacentes les adresses des cellules où on les trouve (du style tulipe A5 B2 F6 voudrait dire tulipe est un doublon que l'on retrouve en A5 , B2 et F6). L'exemple est le fichier joint. En le faisant manuellement, je peux en oublier et cela peut être assez long. Peut-on automatiser cette manip? merci beaucoup!
 

Pièces jointes

  • TEST.xlsm
    42.2 KB · Affichages: 13

Eric KERGRESSE

XLDnaute Occasionnel
Bonjour,

La forme n'est pas la même que votre tableau d'origine, mais cela me paraît suffisant.


VB:
Option Explicit

Sub ListerLesDoublons()

Dim I As Integer, J As Integer, DerniereLigne As Integer, IndexListe As Integer
Dim ListeSansDoublons As Object
Dim Cellule As Range, AireCellules As Range, AireTableau2 As Range
Dim ShResultats As Worksheet
Dim ListeCle As Variant, ListeCellules() As Variant

    IndexListe = 0
    Set ListeSansDoublons = CreateObject("Scripting.Dictionary")
    Set AireTableau2 = Range("TABLEAU2")
        
    For Each Cellule In AireTableau2
        If Cellule <> "" Then
            If Not ListeSansDoublons.Exists(CStr(Cellule)) Then
               ListeSansDoublons.Add CStr(Cellule), Cellule.Address
               ReDim Preserve ListeCellules(1, IndexListe)
               IndexListe = IndexListe + 1
            End If
        End If
    Next Cellule
    
    ListeCle = ListeSansDoublons.keys
    Set ShResultats = Sheets.Add(after:=Sheets(Sheets.Count))
    With ShResultats
    
         For I = LBound(ListeCle) To UBound(ListeCle)
             .Cells(2 + I, 1) = ListeCle(I)
         Next I
        
         With .Columns("A:A")
              .HorizontalAlignment = xlLeft
              .VerticalAlignment = xlBottom
              .WrapText = True
         End With
         DerniereLigne = .Cells(.Rows.Count, 1).End(xlUp).Row
         Set AireCellules = .Range(.Cells(2, 1), .Cells(DerniereLigne, 1))
    
    End With
    
    For I = 1 To AireCellules.Count
        For Each Cellule In AireTableau2
            If Cellule = AireCellules(I) Then AireCellules(I).Offset(0, 1) = AireCellules(I).Offset(0, 1) & Cellule.Address & ", "
        Next Cellule
    Next I
    
    
    For I = AireCellules.Count To 1 Step -1
        If UBound(Split(AireCellules(I).Offset(0, 1), ",")) > 1 Then
           ' AireCellules(I).Offset(0, 2) = UBound(Split(AireCellules(I).Offset(0, 1), ","))
        Else
          AireCellules(I).EntireRow.Delete
        End If
    Next I
    
    AireCellules.ColumnWidth = 40
    
    With Range(AireCellules, AireCellules.Offset(0, 1))
       .EntireRow.AutoFit
       .EntireColumn.AutoFit
       .VerticalAlignment = xlTop
    End With
    
    Set ListeSansDoublons = Nothing: Set AireTableau2 = Nothing:  Set ShResultats = Nothing:  Set AireCellules = Nothing

End Sub


Si les adresses doivent être dans des cellules différentes, il faudra spliter les cellules de la colonne B à la fin du code ou incrémenter la cellule dans la boucle :

Code:
    For I = 1 To AireCellules.Count
        For Each Cellule In AireTableau2
            If Cellule = AireCellules(I) Then AireCellules(I).Offset(0, 1) = AireCellules(I).Offset(0, 1) & Cellule.Address & ", "
        Next Cellule
    Next I
 

finarobert

XLDnaute Nouveau
Supporter XLD
Bonjour,

La forme n'est pas la même que votre tableau d'origine, mais cela me paraît suffisant.


VB:
Option Explicit

Sub ListerLesDoublons()

Dim I As Integer, J As Integer, DerniereLigne As Integer, IndexListe As Integer
Dim ListeSansDoublons As Object
Dim Cellule As Range, AireCellules As Range, AireTableau2 As Range
Dim ShResultats As Worksheet
Dim ListeCle As Variant, ListeCellules() As Variant

    IndexListe = 0
    Set ListeSansDoublons = CreateObject("Scripting.Dictionary")
    Set AireTableau2 = Range("TABLEAU2")
       
    For Each Cellule In AireTableau2
        If Cellule <> "" Then
            If Not ListeSansDoublons.Exists(CStr(Cellule)) Then
               ListeSansDoublons.Add CStr(Cellule), Cellule.Address
               ReDim Preserve ListeCellules(1, IndexListe)
               IndexListe = IndexListe + 1
            End If
        End If
    Next Cellule
   
    ListeCle = ListeSansDoublons.keys
    Set ShResultats = Sheets.Add(after:=Sheets(Sheets.Count))
    With ShResultats
   
         For I = LBound(ListeCle) To UBound(ListeCle)
             .Cells(2 + I, 1) = ListeCle(I)
         Next I
       
         With .Columns("A:A")
              .HorizontalAlignment = xlLeft
              .VerticalAlignment = xlBottom
              .WrapText = True
         End With
         DerniereLigne = .Cells(.Rows.Count, 1).End(xlUp).Row
         Set AireCellules = .Range(.Cells(2, 1), .Cells(DerniereLigne, 1))
   
    End With
   
    For I = 1 To AireCellules.Count
        For Each Cellule In AireTableau2
            If Cellule = AireCellules(I) Then AireCellules(I).Offset(0, 1) = AireCellules(I).Offset(0, 1) & Cellule.Address & ", "
        Next Cellule
    Next I
   
   
    For I = AireCellules.Count To 1 Step -1
        If UBound(Split(AireCellules(I).Offset(0, 1), ",")) > 1 Then
           ' AireCellules(I).Offset(0, 2) = UBound(Split(AireCellules(I).Offset(0, 1), ","))
        Else
          AireCellules(I).EntireRow.Delete
        End If
    Next I
   
    AireCellules.ColumnWidth = 40
   
    With Range(AireCellules, AireCellules.Offset(0, 1))
       .EntireRow.AutoFit
       .EntireColumn.AutoFit
       .VerticalAlignment = xlTop
    End With
   
    Set ListeSansDoublons = Nothing: Set AireTableau2 = Nothing:  Set ShResultats = Nothing:  Set AireCellules = Nothing

End Sub


Si les adresses doivent être dans des cellules différentes, il faudra spliter les cellules de la colonne B à la fin du code ou incrémenter la cellule dans la boucle :

Code:
    For I = 1 To AireCellules.Count
        For Each Cellule In AireTableau2
            If Cellule = AireCellules(I) Then AireCellules(I).Offset(0, 1) = AireCellules(I).Offset(0, 1) & Cellule.Address & ", "
        Next Cellule
    Next I
merci beaucoup. Où dois e inclure le pavé
Code:
 dans le programme? et ce sera parfait
 

mapomme

XLDnaute Barbatruc
Supporter XLD
Bonjour @finarobert, @Eric KERGRESSE, @oguruma, :)

Pour le fun, j'ai entièrement réécrit le code :
  • j'ai modifié le nom du premier onglet "Resultats " qui comportait un espace final. Il n'y a pas mieux pour s'arracher les cheveux quand on fait du codage avec des espaces au début et/ou à la fin des noms d'onglet.
  • on a changé la méthode pour l’accélérer grandement (basée sur un objet collection donc compatible MAC et PC)
  • quand une cellule a un fond de couleur (doublon), on adapte la couleur de police (noir ou blanc) pour mieux distinguer le texte du fond
  • il y a une seule procédure principale qui à la fois colore les doublons de la feuille "Resultats" et liste les adresses des doublons sur la feuille "DOUBLON".
  • on a supprimé le code du module de la feuille "Resultats". Tout le code est dans le module Module1.
  • le code est entièrement commenté (si ça intéresse quelqu'un) ce qui donne l'impression qu'il est long mais ce n'est pas vraiment le cas
Cliquer sur le bouton Hop! de la feuille "Resultats" pour lancer le traitement.
Si les couleurs ne vous conviennent pas, relancer le traitement => vous verrez d'autres couleurs.

nota : je ne vois trop pas à quoi servent les couleurs si ce n'est pour faire sapin de Noël. Il faudrait être sacrément doué pour repérer les couleurs identiques ou distinguer les couleurs "proches" surtout quand on fait du défilement. Au pire, ça donne une idée de la proportion globale de doublon par rapport au singleton. Mais dans ce dernier une couleur unique suffit.
 

Pièces jointes

  • finarobert- Doublon adresse- v1a.xlsm
    61.2 KB · Affichages: 10
Dernière édition:

oguruma

XLDnaute Occasionnel
Une version Full Powerquery+Formule et sans VBA... un peu vite fait si ça peut donner des idées.. )

  • Création d'une table avec toutes les données
1703613284968.png


  • Au préalable les Résultats sont transformés en tableau structuré
1703613337102.png


  • Création de la requête pour obtenir la liste des données - les colonnes sont transformées en ligne
PowerQuery:
let
    Source = Excel.CurrentWorkbook(){[Name="TB_DATA"]}[Content],
    ConvertToColumn = List.Transform(Table.ColumnNames(Source), each Table.Column(Source,_)),
    ConvertToTable = Table.FromList(ConvertToColumn, Splitter.SplitByNothing(), {"LISTES"}, null, ExtraValues.Error),
    ExtractDataFromTable = Table.ExpandListColumn(ConvertToTable, "LISTES"),
    DeleteNul = Table.SelectRows(ExtractDataFromTable, each ([LISTES] <> null and [LISTES] <> "")),
    BackupIDLib = Table.DuplicateColumn(DeleteNul, "LISTES", "LISTES - Copier"),
    ExtractDelim = Table.TransformColumns(BackupIDLib, {{"LISTES", each Text.AfterDelimiter(_, ">sp|"), type text}}),
    Fractionne = Table.SplitColumn(ExtractDelim, "LISTES", Splitter.SplitTextByDelimiter("|", QuoteStyle.Csv), {"LISTES.1", "LISTES.2"}),
    RenCol = Table.RenameColumnas(Fractionne,{{"LISTES.1", "IDENTIFIANT"}, {"LISTES.2", "LIBELLE"}, {"LISTES - Copier", "ID_LIBELLE"}}),
    #"Lignes triées" = Table.Sort(RenCol,{{"IDENTIFIANT", Order.Ascending}})
in
    #"Lignes triées"

  • Création de la requête pour conserver les doublons
PowerQuery:
let
    Source = Excel.CurrentWorkbook(){[Name="TB_DATA"]}[Content],
    ConvertToColumn = List.Transform(Table.ColumnNames(Source), each Table.Column(Source,_)),
    ConvertToTable = Table.FromList(ConvertToColumn, Splitter.SplitByNothing(), {"LISTES"}, null, ExtraValues.Error),
    ExtractDataFromTable = Table.ExpandListColumn(ConvertToTable, "LISTES"),
    DeleteNul = Table.SelectRows(ExtractDataFromTable, each ([LISTES] <> null and [LISTES] <> "")),
    BackupIDLib = Table.DuplicateColumn(DeleteNul, "LISTES", "LISTES - Copier"),
    ExtractDelim = Table.TransformColumns(BackupIDLib, {{"LISTES", each Text.AfterDelimiter(_, ">sp|"), type text}}),
    Fractionne = Table.SplitColumn(ExtractDelim, "LISTES", Splitter.SplitTextByDelimiter("|", QuoteStyle.Csv), {"LISTES.1", "LISTES.2"}),
    RenCol = Table.RenameColumns(Fractionne,{{"LISTES.1", "IDENTIFIANT"}, {"LISTES.2", "LIBELLE"}, {"LISTES - Copier", "ID_LIBELLE"}}),
    #"Lignes triées" = Table.Sort(RenCol,{{"ID_LIBELLE", Order.Ascending}}),
    #"Doublons conservés" = let columnNames = {"IDENTIFIANT"}, addCount = Table.Group(#"Lignes triées", columnNames, {{"Count", Table.RowCount, type number}}), selectDuplicates = Table.SelectRows(addCount, each [Count] > 1), removeCount = Table.RemoveColumns(selectDuplicates, "Count") in Table.Join(#"Lignes triées", columnNames, removeCount, columnNames, JoinKind.Inner),
    #"Doublons supprimés" = Table.Distinct(#"Doublons conservés", {"IDENTIFIANT"})
in
    #"Doublons supprimés"

Puis détection des doublons et localisation - j'ai considéré qu'ils pouvaient apparaître 10 fois mais il suffit de propager la formule au besoin grâce à cette formule
Code:
=SI([@[EQUIV_1]]+COLONNE()-COLONNE($F$1)<[@[NBR DOUBLONS]]+[@[EQUIV_1]];ADRESSE([@[EQUIV_1]]+COLONNE()-COLONNE($F$1);1;1);"")
et voici
1703613826931.png
 

Pièces jointes

  • OGURUMA_TEST_01.xlsm
    79.3 KB · Affichages: 2

finarobert

XLDnaute Nouveau
Supporter XLD
Bonjour @finarobert, @Eric KERGRESSE, @oguruma, :)

Pour le fun, j'ai entièrement réécrit le code :
  • j'ai modifié le nom du premier onglet "Resultats " qui comportait un espace final. Il n'y a pas mieux pour s'arracher les cheveux quand on fait du codage avec des espaces au début et/ou à la fin des noms d'onglet.
  • on a changé la méthode pour l’accélérer grandement (basée sur un objet collection donc compatible MAC et PC)
  • quand une cellule a un fond de couleur (doublon), on adapte la couleur de police (noir ou blanc) pour mieux distinguer le texte du fond
  • il y a une seule procédure principale qui à la fois colore les doublons de la feuille "Resultats" et liste les adresses des doublons sur la feuille "DOUBLON".
  • on a supprimé le code du module de la feuille "Resultats". Tout le code est dans le module Module1.
  • le code est entièrement commenté (si ça intéresse quelqu'un) ce qui donne l'impression qu'il est long mais ce n'est pas vraiment le cas
Cliquer sur le bouton Hop! de la feuille "Resultats" pour lancer le traitement.
Si les couleurs ne vous conviennent pas, relancer le traitement => vous verrez d'autres couleurs.

nota : je ne vois trop pas à quoi servent les couleurs si ce n'est pour faire sapin de Noël. Il faudrait être sacrément doué pour repérer les couleurs identiques ou distinguer les couleurs "proches" surtout quand on fait du défilement. Au pire, ça donne une idée de la proportion globale de doublon par rapport au singleton. Mais dans ce dernier une couleur unique suffit.
super ! ça marche! Merci pour tout!
 

mapomme

XLDnaute Barbatruc
Supporter XLD
Bonjour @finarobert 🙂,

Encore une question qui me chiffonne : dans 'onglet doublons j' ai des références de cellules de l'onglet résultat. Pourrait on les colorer de la couleur de la première cellule de la colonne de ce tableau de l'onglet résultats ?? Merci !

Voir fichier joint.
 

Pièces jointes

  • finarobert- Doublon adresse- v3.xlsm
    61 KB · Affichages: 2

mapomme

XLDnaute Barbatruc
Supporter XLD
Re,

Une amélioration (toute personnelle) parce que je ne suis pas du tout persuadé qu'avoir beaucoup de couleurs améliore la lisibilité.

Tout commence sur la feuille "Doublons".

Sur cette feuille, double-cliquez sur une cellule non vide partir de la ligne 4.
On va alors afficher la feuille "Resultats" en "barrant" d'un trait en diagonal les cellules concernées par la couleur de la ligne double-cliquée.
Il est selon moi beaucoup plus facile de repérer les cellules concernées (barrée en diagonal) que de distinguer les cellules avec la couleur double-cliquée.

Pour éliminer les traits en diagonal, sélectionner l'onglet "DOUBLONS" puis re-sélectionner l'onglet.
En fait, quand on quitte la feuille "DOUBLONS" sans double-cliquer, alors on supprime toutes les traits en diagonal sur la feuille "Resultats".
 

Pièces jointes

  • finarobert- Doublon adresse- v4.xlsm
    67.1 KB · Affichages: 5
Dernière édition:

finarobert

XLDnaute Nouveau
Supporter XLD
Bonjour @finarobert 🙂,



Voir fichier joint.
bonjour et merci pour tout. Je n'ai pas regardé le dernier fichier....je suis à la V3. La couleur dans la première colonne de l'onglet doublons, c'est parfait car je n'y avais pas pensé.
si vous regardez la ligne 1 de l'onglet résultats, il y a deux couleurs ce sont ces couleurs que j'aimerai retrouver si c'est possible sur les cases d'adresse de cellule , cellule à coté des colorisés de l'onglet doublons. Par exemple on a A2 et 02. Sur la cellule A2 je mets la couleur en A1, sr la cellule O2, je mets la couleur de la cellule O1. Si P6, je mets la cellule couleur de la cellule P1. Si c'est dur, on laisse tomber. Déjà colorer la premiere colonne, c'est super! Merci!
je vais regarder le prochain fichier
merci pour tout
Robert
 

Discussions similaires

Statistiques des forums

Discussions
312 520
Messages
2 089 297
Membres
104 092
dernier inscrit
karbone57