XL 2016 copie de doublons sur nouvel onglet

F

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
Trier par date Trier par votes
E

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
 
Vote positif 0 Vote négatif
F

finarobert

XLDnaute Nouveau
Supporter XLD
Eric KERGRESSE à dit:
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
Cliquez pour agrandir...
merci beaucoup. Où dois e inclure le pavé
Code: 
 dans le programme? et ce sera parfait
 
Vote positif 0 Vote négatif
mapomme

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:
Vote positif 0 Vote négatif
oguruma

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
Vote positif 0 Vote négatif
F

finarobert

XLDnaute Nouveau
Supporter XLD
mapomme à dit:
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.
Cliquez pour agrandir...
super ! ça marche! Merci pour tout!
 
Vote positif 0 Vote négatif
mapomme

mapomme

XLDnaute Barbatruc
Supporter XLD
Bonjour @finarobert 🙂,

finarobert à dit:
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 !
Cliquez pour agrandir...

Voir fichier joint.
 

Pièces jointes

  • finarobert- Doublon adresse- v3.xlsm
    61 KB · Affichages: 2
Vote positif 0 Vote négatif
mapomme

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:
Vote positif 0 Vote négatif
F

finarobert

XLDnaute Nouveau
Supporter XLD
mapomme à dit:
Bonjour @finarobert 🙂,



Voir fichier joint.
Cliquez pour agrandir...
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
 
Vote positif 0 Vote négatif

Discussions similaires

F
  • Résolu(e)
XL 2021 recherche doublons dans colonne puis suppression des lignes
Réponses
5
Affichages
175
ftpo69
F
J
  • Résolu(e)
Microsoft 365 Copie cellules dans un autre onglet
Réponses
4
Affichages
244
julien1982
J
M
  • Question
XL 2016 doublons vba
Réponses
10
Affichages
279
marc94600
M
F
  • Question
XL 2016 doublons
2
Réponses
19
Affichages
490
finarobert
F
C
  • Résolu(e)
Microsoft 365 Doublons : mise en surbrillance erronée ?
Réponses
10
Affichages
274
TooFatBoy
TooFatBoy
G
  • Question
XL 2013 Formule SOMMEPROD
Réponses
12
Affichages
199
TooFatBoy
TooFatBoy
A
  • Résolu(e)
XL 2021 suppression de doublons
2 3
Réponses
31
Affichages
978
auloin
A
J
  • Question
XL 2013 Boucle : copie valeur d'une table dans un autre onglet jusqu'à cellule non vide
Réponses
4
Affichages
167
jerome91
J
M
  • Question
Microsoft 365 Somme.Si en enlevant les doublons
Réponses
3
Affichages
137
DJunqueira
D
S
  • Résolu(e)
XL 2016 Générer aléatoirement sans doublons sur même ligne un chiffre de 1 a 17 sur 27 colonnes
Réponses
6
Affichages
269
Seddiki_adz
S

Membres actuellement en ligne

12 membres et 117 invités.

Partager cette page

Tutos vidéos

Power Query : Ajouter des requêtes (Excel et Power BI)
Créez votre première fonction LAMBDA dans Excel en 3 étapes!
LAMBDA, l’arme secrète de Microsoft pour Excel !
Office Insider - Découvrez les nouveautés Excel avant tout le monde

Statistiques des forums

Discussions
312 209
Messages
2 086 259
Membres
103 167
dernier inscrit
miriame