Microsoft 365 doublons en ligne

[Gipéhel]

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.

 

[Gipéhel]

Ci joint un fichier plus explicite.

 

[djidji59430]

Bonjour à tous,

Pas en BVA, mais en PQ

 

[Gipéhel]

Bonjour à tous,

Pas en BVA, mais en PQ

Bonjour à tous,

Pas en BVA, mais en PQ

Bonjour djidji,
Merci, je pensais avoir la solution en VBA car celle que vous m'avez donnée me laisse complétement interrogatif. Que signifie PQ ?
Je suis désolé de mon ignorance.
(vous êtes du nord ? j'habite dans le 62)

 

[laurent950]

Bonsoir @djidji59430 , @Gipéhel , le forum

VBA

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

 

[ALS35]

Bonjour à tous,
Au cas où, une solution par formules dynamiques Excel 365
En H6 une formule unique :

=UNIQUE(A6:A10)

et en I6 une formule à recopier vers le bas :

=FRACTIONNER.TEXTE(JOINDRE.TEXTE("_";0;FILTRE($B$6:$E$16;$A$6:$A$16=H6));"_")

Ce serait bien d'utiliser un tableau structuré
Cordialement

 

[gbinforme]

Bonsoir à tous,

Une formule en VBA basique

 

[Gipéhel]

Bonsoir à tous,

Une formule en VBA basique

Bonsoir à tous,

Une formule en VBA basique

Bonsoir @djidji59430 , @Gipéhel , le forum

VBA

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

 

[Gipéhel]

Bonsoir à tous, merci, c'est exactement ce que je voulais avec des solutions différentes. Gipéhel.

 

[AtTheOne]

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

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

 

[job75]

Bonjour le forum,

Cette macro utilise 2 Dictionary et tous les formats de cellules sont copiés :

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+

 

[job75]

Bien entendu on pourra ne copier que les valeurs, ce sera plus rapide :

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

 

[job75]

Bonjour Gipéhel, le forum,

Si vous voulez les résultats dans la feuille "Résultat" utilisez les fichiers joints.

A+

 

[job75]

Bonjour Gipéhel, le forum,

Une variante un peu plus simple.

A+

 

[Gipéhel]

Bonjour Job75, le forum,
Un grand merci pour les nombreuses solutions qui me conviennent parfaitement.
je vous souhaite un bon week-end. JPL.