XL 2013 Suppression des doublons en conservant leurs données

[GAE13]

Bonjour à tous,
Je me présente Gaë, novice totale, mais très intéressée par les capacités d'Excel
Je cherche une formule pour créer un tableau de données contenant des doublons, triplons ... en regroupant ces données sur une ligne en conservant les données des doublons.
En sachant que je serai amenée à rajouter des données a trier régulièrement dans ce tableau
Je n'ai pas beaucoup de notions mais çà me semble pourtant réalisable
Suppression des doublons colonne A en recopiant les données des doublons de la colonne b dans les colonnes b - c - d ...
Je ne connais pas le nombre de fois ou la composante A sera identique de 0 à 10 doublons et nombres de lignes 8000 maxi
Merci d'avance pour vos idées
Bonne soirée, voir bonne nuit (oups le temps passe toujours vite sur un ordi)
nota à la base ma colonne B contient des dates

CERISE	D		​	​	​
CERISE	A
CERISE	D
FRAISE	D
FRAISE	C
FRAISE	A
POIRE	D
POIRE	F
POMME	A
POMME	E
POMME	D
Suppression des doublons colonne A en recopiant les données colonne b dans b - c et d
CERISE	D	A	D
FRAISE	D	C	A
POIRE	D	F
POMME	A	E	D

 

[Jacky67]

Bonjour à tous,
Je me présente Gaë, novice totale, mais très intéressée par les capacités d'Excel
Je cherche une formule pour créer un tableau de données contenant des doublons, triplons ... en regroupant ces données sur une ligne en conservant les données des doublons.
En sachant que je serai amenée à rajouter des données a trier régulièrement dans ce tableau
Je n'ai pas beaucoup de notions mais çà me semble pourtant réalisable
Suppression des doublons colonne A en recopiant les données des doublons de la colonne b dans les colonnes b - c - d ...
Je ne connais pas le nombre de fois ou la composante A sera identique de 0 à 10 doublons et nombres de lignes 8000 maxi
Merci d'avance pour vos idées
Bonne soirée, voir bonne nuit (oups le temps passe toujours vite sur un ordi)
nota à la base ma colonne B contient des dates

CERISE	D		​	​	​
CERISE	A
CERISE	D
FRAISE	D
FRAISE	C
FRAISE	A
POIRE	D
POIRE	F
POMME	A
POMME	E
POMME	D
Suppression des doublons colonne A en recopiant les données colonne b dans b - c et d
CERISE	D	A	D
FRAISE	D	C	A
POIRE	D	F
POMME	A	E	D

Bonjour,
Une proposition en PJ par VBA avec ce code dans le module de la feuille2
Dans cet exemple, un titre est nécessaire un ligne 1.
Les dates sont des dates reconnues par Excel.
La mise à jour se fait en sélectionnant la feuil2

Private Sub Worksheet_Activate()
    Dim Plage, C As Range, D As Range, Col&
    With Application: .ScreenUpdating = False: .Calculation = xlManual: .EnableEvents = False: End With
    Cells.Clear
    With Feuil1
        If .FilterMode Then .ShowAllData
        Set Plage = .Range("A1:A" & .Cells(.Rows.Count, "A").End(xlUp).Row)
        Plage.AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Range("A1"), Unique:=True
    End With
    For Each C In Range("A2:A" & Cells(Rows.Count, "A").End(xlUp).Row)
        Col = 2
        Plage.AutoFilter Field:=1, Criteria1:=C
        For Each D In Plage.Offset(1).Resize(Plage.Rows.Count - 1).SpecialCells(xlCellTypeVisible)
            Cells(C.Row, Col) = CDate(D.Offset(, 1))
            Col = Col + 1
        Next
    Next
    Plage.AutoFilter
    With Application: .EnableEvents = True: .Calculation = xlAutomatic: .ScreenUpdating = True: End With
End Sub

 

[job75]

Bonjour GAE13, Jacky67,

Voyez le fichier joint et cette macro dans le code de la feuille "Résultat" :

Private Sub Worksheet_Activate()
Dim d As Object, tablo, i&, x$, a, b(), s, ub%, ubmax%, j%
Set d = CreateObject("Scripting.Dictionary")
d.CompareMode = vbTextCompare 'la casse est ignorée
tablo = Sheets("BDD").[A1].CurrentRegion.Resize(, 2) 'matrice, plus rapide
For i = 1 To UBound(tablo)
    x = tablo(i, 1)
    If Not d.exists(x) Then d(x) = x
    d(x) = d(x) & Chr(1) & tablo(i, 2)
Next
'---restitution---
Application.ScreenUpdating = False
If FilterMode Then ShowAllData 'si la feuille est filtrée
Cells.Delete 'RAZ
If d.Count Then
    a = d.items
    ReDim b(UBound(a), Columns.Count - 1) 'base 0
    For i = 0 To UBound(a)
        s = Split(a(i), Chr(1))
        ub = UBound(s)
        If ub > ubmax Then ubmax = ub
        For j = 0 To UBound(s)
            b(i, j) = s(j)
    Next j, i
    If ubmax + 1 Then [A1].Resize(i, ubmax + 1) = b
    Columns.AutoFit 'ajuste les largeurs
End If
With UsedRange: End With 'actualise les barres de défilement
End Sub

Elle se déclenche automatiquement quand on active la feuille.

Elle est très rapide car elle utilise des tableaux VBA et un Dictionary.

A+

 

[mapomme]

Bonjour à tous,

Une autre méthode sans dictionary (pour nos amis MACiste ) mais malgre cela assez rapide. On détecte s'il y a des en-têtes ou non dans la source (B1 est une date ou pas). Cliquer sur le bouton Hop!
Le code:

Sub EnLigne()
Dim PresenceTitre As Boolean, der&, t, ref, i&, n&, k&, max&, CellulleRes As Range
   Application.ScreenUpdating = False
   With Sheets("Feuil1")
      PresenceTitre = Not (IsDate(.Range("b1")))
      If .FilterMode Then .ShowAllData
      der = .Cells(.Rows.Count, "a").End(xlUp).Row
      .Range("d1").CurrentRegion.Clear
      .Range("d1").Resize(der, 2) = .Range("a1").Resize(der, 2).Value
      .Range("d1").Resize(der, 2).Sort key1:=.Range("d1"), order1:=xlAscending, Header:=IIf(PresenceTitre, xlYes, xlNo)
      t = .Range("d1").Resize(der, 2)
      .Range("d1").Resize(der).RemoveDuplicates Columns:=1, Header:=IIf(PresenceTitre, xlYes, xlNo)
      der = .Cells(.Rows.Count, "d").End(xlUp).Row
      .Range("e1").EntireColumn.Clear
      ReDim r(1 To der, 1 To 1)
      n = 1: ref = t(1, 1): r(n, 1) = t(1, 2): k = 1: max = 1
      For i = 2 To UBound(t)
         If t(i, 1) = ref Then
            r(n, 1) = r(n, 1) & ";" & t(i, 2)
            k = k + 1
            If k > max Then max = k
         Else
            n = n + 1: ref = t(i, 1): r(n, 1) = t(i, 2): k = 1
         End If
      Next i
      .Range("e1").Resize(UBound(r), UBound(r, 2)) = r
      ReDim f(0 To max - 1)
      For i = 0 To max - 1: f(i) = Array(i + 1, xlDMYFormat): Next
      .Range("e1").Resize(UBound(r)).TextToColumns Destination:=.Range("e1"), DataType:=xlDelimited, Semicolon:=True, FieldInfo:=f
      .Range("d1").Resize(der, max + 1).Interior.Color = RGB(225, 225, 225)
      .Range("d1").Resize(, max + 1).EntireColumn.AutoFit
      .Range("e1").HorizontalAlignment = xlRight
   End With
End Sub

 

[mapomme]

Bonjour @job75 ,

Quand j'applique ta macro sur mes données sources, j'obtiens un résultat avec une partie des cellules contenant une date en texte et dans les autres cellules une véritable date. D'où cela vient-il donc ?
Sans doute un problème de date format US/FR puisque toutes les dates commençant par un jour supérieur à 12 (soit le mois de décembre en format US) deviennent du texte.

 

[GAE13]

Bonjour et merci à vous deux Jacky67 et Job 75
J'ai testé vos méthodes et c'est exactement ce que je voulais par contre j 'ai oublié de préciser que le fichier auquel cette macro va être destinée contient des colonnes de A à N.
Mon tri va s'effectuer sur la colonne F (code client) et les dates que je récupère sont dans la colonne E.
Dans mon résultat je souhaite récupérer les donnés complètes de A à N de la ligne de date la plus récente et que les dates récupérées s'affiche dans les colonnes à partir du O.
Est ce possible ?
En vous remerciant par avance
Nota Mapomme merci à vous aussi j'adore le "hop"
en attendant de vous lire bonne journée à vous tous

 

[mapomme]

Re @GAE13 ,

Le mieux (et c'est précisé dans la charte du site XLD) est de nous fournir un fichier anonymisé qui reflète en tout point la structure et les données de votre fichier et qui présente un exemple de résultat souhaité.

En général, les répondeurs n'apprécient guère les discussions à tiroirs dont la cause est un fichier non fourni ou bien un fichier qui n'est pas analogue au fichier utilisé par le questionneur. Péché de jeunesse ?

A très vite avec le "bon" classeur...

 

[mapomme]

j'adore le "hop"

C'est le côté "taquin" d'Excel

 

[soan]

Bonjour mapomme, le fil,

les répondeurs n'apprécient guère les discussions à tiroirs ... c'est le côté "taquin" d'Excel

normal, les répondeurs ne sont pas faits pour être rangés dans un tiroir : c'est mieux qu'ils soient posés sur la table, près du téléphone. (c'est mon côté "taquin" ! )​

soan

 

[job75]

Bonjour mapomme, soan,

Bonjour @job75 ,

Quand j'applique ta macro sur mes données sources, j'obtiens un résultat avec une partie des cellules contenant une date en texte et dans les autres cellules une véritable date. D'où cela vient-il donc ?

Essaie donc en ajoutant .Value2 pour remplacer les dates par leurs valeurs numériques :

tablo = Sheets("BDD").[A1].CurrentRegion.Resize(, 2).Value2 'matrice, plus rapide

A+

 

[GAE13]

Re bonjour
Ci joint un ficher test identique à mon fichier de base feuille 1 "donnes" feuille 2 "le résultat attendu"
ce sera beaucoup plus clair
Merci d'avance et bonne après midi

 

[mapomme]

Re,
bonjour @soan,

Un essai avec le nouveau fichier. J'ai pris comme hypothèses:

• pas d'en-tête
• pour une ligne du résultat, les colonnes de A à N sont les informations de la date la plus récente
• pour une ligne du résultat, les dates à partir de la colonne O sont triées de la date la plus récente à la date la plus ancienne

 

[job75]

Il n'est pas très difficile d'adapter la macro du post #3 au nouveau fichier :

Private Sub Worksheet_Activate()
Dim ncol%, d As Object, tablo, i&, x$, y$, a, b(), s, ub%, ubmax%, j%
ncol = 14 'nombre de colonnes du tableau source
Set d = CreateObject("Scripting.Dictionary")
d.CompareMode = vbTextCompare 'la casse est ignorée
tablo = Sheets("BDD").[A1].CurrentRegion.Resize(, ncol).Value2 'matrice, plus rapide
For i = 1 To UBound(tablo)
    x = tablo(i, 6) 'colonne F
    If Not d.exists(x) Then
        y = ""
        For j = 1 To ncol: y = y & Chr(1) & tablo(i, j): Next j
        d(x) = Mid(y, 2)
    End If
    d(x) = d(x) & Chr(1) & tablo(i, 5) 'dates en colonne E
Next i
'---restitution---
Application.ScreenUpdating = False
If FilterMode Then ShowAllData 'si la feuille est filtrée
Cells.Delete 'RAZ
If d.Count Then
    a = d.items
    ReDim b(UBound(a), Columns.Count - 1) 'base 0
    For i = 0 To UBound(a)
        s = Split(a(i), Chr(1))
        ub = UBound(s)
        If ub > ubmax Then ubmax = ub
        For j = 0 To UBound(s)
            b(i, j) = s(j)
    Next j, i
    If ubmax + 1 Then
        With [A1].Resize(i, ubmax + 1)
            .Value = b
            Union(.Columns(5), .Columns(ncol + 1).Resize(, ubmax + 1 - ncol)).NumberFormat = "dd/mm/yyyy"
        End With
    End If
    Columns.AutoFit 'ajuste les largeurs
End If
With UsedRange: End With 'actualise les barres de défilement
End Sub