Microsoft 365 doublons en ligne

Boostez vos compétences Excel avec notre communauté !

Rejoignez Excel Downloads, le rendez-vous des passionnés où l'entraide fait la force. Apprenez, échangez, progressez – et tout ça gratuitement ! 👉 Inscrivez-vous maintenant !

Gipéhel

XLDnaute Occasionnel
Bonjour,
Le fichier ci joint montre ce que je désirerais obtenir à l'aide d'un module VBA.
Regrouper en une ligne les données qui suivent les doublons.
Je vous remercie d'avance.
Gipehel.
 

Pièces jointes

Bonsoir @djidji59430 , @Gipéhel , le forum

VBA

VB:
Sub doublons()

    ' Créer un dictionnaire pour suivre les doublons
    Dim dico As Object
    Set dico = CreateObject("Scripting.Dictionary")
    
    ' Définir la plage des cellules à analyser
    Dim Cell As Range
    Set Cell = Range("A6:A" & Range("A65000").End(xlUp).Row)
    
    ' Déclarer les variables supplémentaires
    Dim c As Range
    Dim t As Variant
    Dim i As Long
    Dim cpt As Integer
    
    ' Parcourir chaque cellule dans la colonne A
    For Each c In Cell
        cpt = 1 ' Réinitialiser le compteur à chaque ligne
        
        If Not dico.Exists(c.Value) Then
            ' Si la valeur n'existe pas encore, ajouter une nouvelle entrée dans le dictionnaire
            t = Range(Cells(c.Row, 1), Cells(c.Row, c.Offset(, 4).Column)).Value
            dico.Add c.Value, t
        Else
            ' Si la valeur existe déjà, agrandir le tableau avec 4 nouvelles colonnes
            t = dico(c.Value)
            ReDim Preserve t(1 To UBound(t, 1), 1 To UBound(t, 2) + 4)
            
            ' Ajouter les nouvelles valeurs à la fin du tableau
            For i = UBound(t, 2) - 3 To UBound(t, 2)
                t(1, i) = c.Offset(, cpt).Value
                cpt = cpt + 1
            Next i
            
            ' Mettre à jour le dictionnaire avec les nouvelles données
            dico(c.Value) = t
        End If
    Next c

    ' Variables pour l'affichage dans la feuille
    Dim r As Integer
    r = 11 ' Début de la ligne d'affichage
    
    ' Afficher les résultats dans la feuille à partir de la colonne 8
    For Each t In dico.Items
        r = r + 1
        Cells(r, 8).Resize(UBound(t, 1), UBound(t, 2)).Value = t
    Next t

    ' Nettoyage des objets
    Set dico = Nothing
    Set c = Nothing
    Set Cell = Nothing
    t = Empty
    cpt = Empty
    i = Empty

End Sub
 
Bonjour à tous,
Au cas où, une solution par formules dynamiques Excel 365
En H6 une formule unique :
Code:
=UNIQUE(A6:A10)
et en I6 une formule à recopier vers le bas :
VB:
=FRACTIONNER.TEXTE(JOINDRE.TEXTE("_";0;FILTRE($B$6:$E$16;$A$6:$A$16=H6));"_")
Ce serait bien d'utiliser un tableau structuré
Cordialement
 

Pièces jointes

Dernière édition:
Bonsoir à tous,

Une formule en VBA basique
Bonsoir à tous,

Une formule en VBA basique
Bonsoir @djidji59430 , @Gipéhel , le forum

VBA

VB:
Sub doublons()

    ' Créer un dictionnaire pour suivre les doublons
    Dim dico As Object
    Set dico = CreateObject("Scripting.Dictionary")
  
    ' Définir la plage des cellules à analyser
    Dim Cell As Range
    Set Cell = Range("A6:A" & Range("A65000").End(xlUp).Row)
  
    ' Déclarer les variables supplémentaires
    Dim c As Range
    Dim t As Variant
    Dim i As Long
    Dim cpt As Integer
  
    ' Parcourir chaque cellule dans la colonne A
    For Each c In Cell
        cpt = 1 ' Réinitialiser le compteur à chaque ligne
      
        If Not dico.Exists(c.Value) Then
            ' Si la valeur n'existe pas encore, ajouter une nouvelle entrée dans le dictionnaire
            t = Range(Cells(c.Row, 1), Cells(c.Row, c.Offset(, 4).Column)).Value
            dico.Add c.Value, t
        Else
            ' Si la valeur existe déjà, agrandir le tableau avec 4 nouvelles colonnes
            t = dico(c.Value)
            ReDim Preserve t(1 To UBound(t, 1), 1 To UBound(t, 2) + 4)
          
            ' Ajouter les nouvelles valeurs à la fin du tableau
            For i = UBound(t, 2) - 3 To UBound(t, 2)
                t(1, i) = c.Offset(, cpt).Value
                cpt = cpt + 1
            Next i
          
            ' Mettre à jour le dictionnaire avec les nouvelles données
            dico(c.Value) = t
        End If
    Next c

    ' Variables pour l'affichage dans la feuille
    Dim r As Integer
    r = 11 ' Début de la ligne d'affichage
  
    ' Afficher les résultats dans la feuille à partir de la colonne 8
    For Each t In dico.Items
        r = r + 1
        Cells(r, 8).Resize(UBound(t, 1), UBound(t, 2)).Value = t
    Next t

    ' Nettoyage des objets
    Set dico = Nothing
    Set c = Nothing
    Set Cell = Nothing
    t = Empty
    cpt = Empty
    i = Empty

End Sub
 
Bonjour à toutes & à tous, bonjour @Gipéhel

J'arrive comme très souvent après la bagarre mais je poste quand même ma solution :
Comme dit plus haut par @ALS35, c'est mieux d'utiliser un tableau structuré, c'est ce que j'ai fait, je l'ai nommé "Tb_Liste"

On ne place qu'une seule formule (à base de LAMBDA) avec comme argument le tableau d'entrée.

Une seule formule qui s'étend automatiquement, pas besoin de tirer vers la droite ou vers le bas et qui s'adapte automatiquement au changements dans le tableau d'entrée; pas besoin de faire actualiser ou de rappeler une macro.

Elle s'appelle simplement par la formule =ListeParAdresse(Tb_liste)

La formule est une combinaison des fonctions LAMBDA, LET, DECALER, BYROW, JOINDRE.TEXTE, FRACTIONNER.TEXTE SIERREUR et ASSEMB.H,
rien que cela ! 😄


Voici le nom défini pour utiliser cette formule
ListeParAdresse=LAMBDA(Tableau;LET(A;DECALER(Tableau;0;0;;1);
B;DECALER(Tableau;0;1;;4);
Critère;UNIQUE(A);
R;BYROW(Critère;LAMBDA(C;LET(X;FILTRE(B;A=C);
JOINDRE.TEXTE(";";FAUX;X))));
Lgn;JOINDRE.TEXTE("|";FAUX;R);
D;SIERREUR(FRACTIONNER.TEXTE(Lgn;";";"|";FAUX);"");
ASSEMB.H(Critère;D)))

EXPLICATIONS
=LAMBDA(Tableau; Permet d'utiliser le nom défini "ListeParAdresse" avec l'argument Tableau
1736886783825.png
1736886945591.png

définir une série de paramètres et une formule de calcul finale
LET(
Paramètre 1 : la 1ère colonne de Tableau
A;DECALER(Tableau;0;0;;1);

Paramètre 2 : les 4 dernières colonnes de Tableau
B;DECALER(Tableau;0;1;;4);

Paramètre 3 : la liste des adresses (sans doublon)
Critère;UNIQUE(A);

Paramètre 4 : pour chaque ligne C de Critère va exécuter la fonction LET qui suit
R;BYROW(Critère;LAMBDA(C;
LET(X;FILTRE(B;A=C);JOINDRE.TEXTE(";";FAUX;X))));
X : les lignes (1 ou plusieurs lignes de 4 colonnes) de Tableau correspondant à l'adresse C ,
on joint les toutes les cellules séparées par des ";"

Paramètres 5 : on joint dans une seule ligne les lignes contenues dans R en les séparant par des "|"[/COLOR]
Lgn;JOINDRE.TEXTE("|";FAUX;R);

Paramètres 6 : on sépare en colonnes et en ligne la chaine Lgn en utilisant les séparateur de colonne ";" et de ligne "|"
D;SIERREUR(FRACTIONNER.TEXTE(Lgn;";";"|";FAUX);"");

Formule finale, on assemble les adresses avec le tableau contenu dans D (SIERREUR est là pour éliminer les #N/A des lignes ne contenant pas le maximum de colonnes renvoyées
ASSEMB.H(Critère;D)))



Voilà à toi de voir

EDIT : Ajout avec ton 2ième fichier
A bientôt
 

Pièces jointes

Dernière édition:
Bonjour le forum,

Cette macro utilise 2 Dictionary et tous les formats de cellules sont copiés :
VB:
Sub Transfert()
Dim ncol%, dest As Range, dlig As Object, dcol As Object, lig&, destcol%, i&, x$
ncol = 5 'nombre de colonnes du tableau source
Set dest = [I5] 'cellule de destination
Set dlig = CreateObject("Scripting.Dictionary")
dlig.CompareMode = vbTextCompare 'la casse est ignorée
Set dcol = CreateObject("Scripting.Dictionary")
dcol.CompareMode = vbTextCompare 'la casse est ignorée
lig = dest.Row
destcol = dest.Column
Application.ScreenUpdating = False
dest.Resize(Rows.Count - lig + 1, Columns.Count - destcol + 1).Clear 'RAZ
For i = 5 To Cells(Rows.Count, 1).End(xlUp).Row
    x = Cells(i, 1)
    If dlig.exists(x) Then
        Cells(i, 2).Resize(, ncol - 1).Copy Cells(dlig(x), dcol(x)) 'copier-coller
        dcol(x) = dcol(x) + ncol - 1
    Else
        dlig(x) = lig
        dcol(x) = destcol + ncol
        Cells(i, 1).Resize(, ncol).Copy Cells(lig, destcol) 'copier-coller
        lig = lig + 1
    End If
Next
With dest.EntireColumn.Resize(, Columns.Count - dest.Column + 1)
    .ColumnWidth = 10.71
    .AutoFit 'ajustement largeurs
End With
End Sub
A+
 

Pièces jointes

Bien entendu on pourra ne copier que les valeurs, ce sera plus rapide :
VB:
Sub Transfert()
Dim ncol%, dest As Range, dlig As Object, dcol As Object, lig&, destcol%, i&, x$
ncol = 5 'nombre de colonnes du tableau source
Set dest = [I5] 'cellule de destination
Set dlig = CreateObject("Scripting.Dictionary")
dlig.CompareMode = vbTextCompare 'la casse est ignorée
Set dcol = CreateObject("Scripting.Dictionary")
dcol.CompareMode = vbTextCompare 'la casse est ignorée
lig = dest.Row
destcol = dest.Column
Application.ScreenUpdating = False
dest.Resize(Rows.Count - lig + 1, Columns.Count - destcol + 1).Clear 'RAZ
For i = 5 To Cells(Rows.Count, 1).End(xlUp).Row
    x = Cells(i, 1)
    If dlig.exists(x) Then
        Cells(dlig(x), dcol(x)).Resize(, ncol - 1) = Cells(i, 2).Resize(, ncol - 1).Value 'copie les valeurs
        dcol(x) = dcol(x) + ncol - 1
    Else
        dlig(x) = lig
        dcol(x) = destcol + ncol
        Cells(lig, destcol).Resize(, ncol) = Cells(i, 1).Resize(, ncol).Value 'copie les valeurs
        lig = lig + 1
    End If
Next
With dest.EntireColumn.Resize(, Columns.Count - dest.Column + 1)
    .ColumnWidth = 10.71
    .AutoFit 'ajustement largeurs
End With
End Sub
 

Pièces jointes

- Navigue sans publicité
- Accède à Cléa, notre assistante IA experte Excel... et pas que...
- Profite de fonctionnalités exclusives
Ton soutien permet à Excel Downloads de rester 100% gratuit et de continuer à rassembler les passionnés d'Excel.
Je deviens Supporter XLD

Discussions similaires

Réponses
17
Affichages
411
Réponses
40
Affichages
1 K
  • Question Question
Microsoft 365 Excel graphique
Réponses
3
Affichages
114
Réponses
9
Affichages
386
  • Question Question
XL 2021 Doublons
Réponses
7
Affichages
135
Réponses
4
Affichages
164
Retour