valeur en double et date la plus récente

[coolreds]

Bonjour

j'ai un fichier de 300 000 lignes

Colonne A des valeurs en double, triple ou voir plus
Colonne B (date)
Colonne C (valeur diverse)

je souhaite supprimer les valeurs en doubles dans la colonne A avec pour critère de garder la valeur avec la date la plus récente et sa valeur diverse en C

j'ai fait un exemple sur le fichier en PJ

Merci pour votre aide

 

[CISCO]

Bonjour

Est-ce que dans ton vrai fichier, les dates sont classées dans un ordre particulier ? Si oui, lequel ?

Est-ce que tu es contre une macro, parce qu'avec des formules, avec 300 000 lignes, cela risque de ramer...

@ plus

 

[job75]

Bonjour coolreds, CISCO,

Dans le fichier joint voyez les 3 noms définis et les 3 formules matricielles en colonnes E F G.

A+

 

[CISCO]

Bonjour à tous, bonjour Job75

On peut faire avec des formules matricielles, mais comme il me semble que cela va demander pas mal de temps de calcul, j'ai fait avec une seule formule matricielle (en rouge) dans une colonne intermédiaire, à valider avec Ctrl+maj+entrer.

@ plus

 

[job75]

Bonjour le fil, le forum,

Je pense qu'une solution par formules n'est pas envisageable avec 300 000 lignes.

Testez donc cette solution VBA :

Sub Tri_Max()
Dim dur#, P As Range, dest As Range, t, a(), d As Object, i&
dur = Timer
Set P = Feuil1.[A1].CurrentRegion 'CodeName à adapter
Set dest = Feuil1.[E1] '1ère cellule du 2ème tableau, à adapter
'---préparation---
Application.ScreenUpdating = False
If P.Parent.FilterMode Then P.Parent.ShowAllData 'si la feuille est filtrée
P.EntireColumn.Resize(, 2).Insert 'insère 2 colonnes auxiliaires
Set P = P.Offset(, -2).Resize(, P.Columns.Count + 2)
P(1) = 1: P.Columns(1).DataSeries 'repère l'ordre initial
If P.Rows.Count > 1 Then P.Sort P(1, 3), xlAscending, P(1, 4), , xlDescending, Header:=xlYes 'tri sur 2 colonnes
'---valeurs uniques---
t = P.Columns(3).Resize(P.Rows.Count + 1) 'matrice, plus rapide, au moins 2 éléments
ReDim a(1 To UBound(t) - 1, 1 To 1)
Set d = CreateObject("Scripting.Dictionary")
d.CompareMode = vbTextCompare 'la casse est ignorée (si nécessaire)
For i = 1 To UBound(a)
  If Not d.exists(t(i, 1)) Then d(t(i, 1)) = "": a(i, 1) = 1 'repère
Next
P.Columns(2) = a
P.Sort P(1, 2) 'tri pour regrouper les 1
'---resultat---
dest(2).Resize(Rows.Count - dest.Row, P.Columns.Count - 2).Delete xlUp 'RAZ
If P.Rows.Count = 1 Then Set P = P.Resize(2) 'si le tableau est vide
P.Columns(2).SpecialCells(xlCellTypeConstants, 1).Offset(, 1).Resize(, P.Columns.Count - 2).Copy dest 'transfert
P.Sort P(1), xlAscending 'tri dans l'ordre initial
P.EntireColumn.Resize(, 2).Delete 'suppression des 2 colonnes auxiliaires
dest.EntireColumn.Resize(, P.Columns.Count).AutoFit 'ajustement largeur
Application.ScreenUpdating = True
MsgBox d.Count - 1 & " " & dest & " récupérés en " & Format(Timer - dur, "0.00 \s") 'mesure facultative
End Sub

Edit : j'ai soigné le cas où le tableau source est vide.

Fichier joint.

Chez moi sur 300 000 lignes :

- avec 1 valeur unique => 7 secondes

- avec 30 000 valeurs uniques => 9,5 secondes

- avec 300 000 valeurs uniques (pas de doublon) => 30 secondes.

Bonne journée.

 

[laetitia90]

bonjour tous
en utilisant remove duplicates

Sub es()
Range("a2:c" & Cells(Rows.Count, 2).End(3).Row).Sort Key1:=[b2], Order1:=xlDescending, Header:=xlGuess
Range("a1:c" & Cells(Rows.Count, 2).End(3).Row).RemoveDuplicates Columns:=1, Header:=xlYes
End Sub

 

[job75]

Bonjour chère Laetitia

Ah mais bien sûr avec RemoveDuplicates c'est bien plus simple, merci beaucoup :

Sub Tri_Max()
Dim t#, P As Range, dest As Range
t = Timer
Set P = Feuil1.[A1].CurrentRegion 'CodeName à adapter
Set dest = Feuil1.[E1] '1ère cellule du 2ème tableau, à adapter
Application.ScreenUpdating = False
If P.Parent.FilterMode Then P.Parent.ShowAllData 'si la feuille est filtrée
dest(2).Resize(Rows.Count - dest.Row, P.Columns.Count).Delete xlUp 'RAZ
P.Copy dest 'tranfert du tableau
Set P = dest.CurrentRegion
P.Sort P(1, 2), xlDescending, Header:=xlYes 'tri sur les dates
P.RemoveDuplicates Columns:=1, Header:=xlYes 'suppression des doublons
P.CurrentRegion.Sort P(1), xlAscending, Header:=xlYes 'tri sur la 1ère colonne
P.EntireColumn.AutoFit 'ajustement largeur
Application.ScreenUpdating = True
MsgBox P.CurrentRegion.Rows.Count - 1 & " " & dest & " récupérés en " & Format(Timer - t, "0.00 \s") 'mesure facultative
End Sub

Fichier (2).

Chez moi sur 300 000 lignes :

- avec 1 valeur unique => 3 secondes

- avec 30 000 valeurs uniques => 7 secondes

- avec 300 000 valeurs uniques (pas de doublon) => 25 secondes.

Nota : RemoveDuplicates n'existe pas sur les anciennes versions Excel.

Edit : fonctionne sur Excel 2010.

C'est la 1ère fois que je l'utilise.

A+

 

[job75]

Bonjour le fil, le forum,

Si l'on veut récupérer seulement les valeurs, sans les formats, ceci est plus rapide :

Sub Tri_Max()
Dim dur#, dest As Range, ncol%, t, d As Object, i&, x$, a, b, rest(), n&, j%
dur = Timer
Set dest = Feuil1.[E1] '1ère cellule du 2ème tableau, à adapter
Application.ScreenUpdating = False
If dest.Parent.FilterMode Then dest.Parent.ShowAllData 'si la feuille est filtrée
With Feuil1.[A1].CurrentRegion
  .Rows(1).Copy dest 'en-têtes
  ncol = .Columns.Count
  t = .Resize(, IIf(ncol = 1, 2, ncol)).Value2 'matrice, plus rapide, au moins 2 éléments
End With
Set d = CreateObject("Scripting.Dictionary")
For i = 2 To UBound(t)
  If d.exists(t(i, 1)) Then
    x = d(t(i, 1))
    If Val(t(i, 2)) > Val(Left(x, InStr(x, Chr(1)) - 1)) Then d(t(i, 1)) = t(i, 2) & Chr(1) & i
  Else
    d(t(i, 1)) = t(i, 2) & Chr(1) & i 'date + ligne
  End If
Next
If d.Count Then
  a = d.keys: b = d.items
  ReDim rest(1 To d.Count, 1 To ncol)
  For i = 1 To UBound(rest)
    rest(i, 1) = a(i - 1)
    x = b(i - 1)
    n = Mid(x, InStr(x, Chr(1)) + 1)
    For j = 2 To ncol
      rest(i, j) = t(n, j)
  Next j, i
  dest(2).Resize(i - 1, ncol) = rest 'resttitution
  dest.Resize(i, ncol).Sort dest, xlAscending, Header:=xlYes 'tri sur la 1ère colonne
  dest(1, 2).EntireColumn.NumberFormat = "dd/mm/yyyy" 'au cas où
End If
dest(2).Offset(d.Count).Resize(Rows.Count - d.Count - dest.Row, ncol).ClearContents 'RAZ en dessous
dest.EntireColumn.Resize(, ncol).AutoFit 'ajustement largeur
Application.ScreenUpdating = True
MsgBox d.Count & " " & dest & " récupérés en " & Format(Timer - dur, "0.00 \s") 'mesure facultative
End Sub

Fichier (3).

Chez moi sur 300 000 lignes :

- avec 1 valeur unique => 2 secondes

- avec 30 000 valeurs uniques => 3,5 secondes

- avec 300 000 valeurs uniques (pas de doublon) => 15 secondes.

Bonne journée.

 

[coolreds]

Bonjour

Merci à tous pour votre retour, effectivement la macro est impeccable

Trop fort ;-)

 

[Loïc DUBOIS]

Bonjour à tous,

Sujet très intéressant.

J'ai moi même besoin de faire une manipulation casi similaire. La seule différence est que je veux qu'il y ait plusieurs colonne similaire pour les supprimer.

Je m'explique, j'ai un fichier excel avec environ 21k lignes. Parmis ces lignes se trouve des doublons. Or je veux les supprimer en ne gardant que le doublon le plus ancien. Je caractérise les doublons sur plusieurs colonnes. Un doublon est avéré lorsque la colonne "Année" (B), "Personne" (D), "Fonction" (H), RIC (L).

Pour résumer, pouvez-vous m'aider à supprimer les doublons lorsque les 4 colonnes ci-dessus sont identiques et ne garder uniquement la ligne la plus ancienne (colonne A) ?

Je vous joint un fichier exemple : dans ce fichier j'ai des doublons avec "Amazon" (colonne B, D, H et L identiques mais je souhaite ne garder que la ligne avec la date la plus ancienne (colonne A). (je ne peux insérer mon fichier...)

 

[CISCO]

Bonjour

Essayes avec un fichier très, très allégé...

@ plus