[XL-2003] Suppression doublons [Résolu]

[Albatros47]

Bonjour à tous,

Je voudrai sur une feuille donnée supprimer les lignes qui pourraient être saisies en double et n'en garder qu'une.

Sachant que chaque ligne serait composée de 5 colonnes Maxi.

J'arrive à faire fonctionner ma macro en considérant la colonne A comme référence, mais au delà de 2 colonnes je n'arrive pas à comprendre comment constituer le code de suppression.

Des explications et un petit exemple seraient les bienvenus.

Merci à tous.

[Gorfael]

Salut Albatros47 et le

forumJ'arrive à faire fonctionner ma macro en considérant la colonne A comme référence, mais au delà de 2 colonnes je n'arrive pas à comprendre comment constituer le code de suppression.

Tu as donc créé une macro qui ne te suffit pas. Donnes ton code pour qu'on puisse le modifier.
A+

[Albatros47]

Bonjour,

Voilà le code que j'ai essayé:

Code :

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
Sub supprimeDoublons()
 
MaCellule = ("A1")
Range(MaCellule).Select
ActiveCell.CurrentRegion.Sort Key1:=Range(MaCellule), Order1:=xlAscending, Header:=xlYes
donnee1 = ActiveCell
ActiveCell.Offset(1, 0).Select
 
While ActiveCell <> ""
If ActiveCell = donnee1 Then
ActiveCell.EntireRow.Delete
ActiveCell.Offset(-1, 0).Select
donnee1 = ActiveCell
ActiveCell.Offset(1, 0).Select
Else
donnee1 = ActiveCell
ActiveCell.Offset(1, 0).Select
End If
Wend
End Sub

Je souhaite vérifier la ligne entière.

Paul 1 Mars 10:30 12:30= doublon
Paul 1 Mars 10:30 12:30= doublon
Paul 2 Mars 10:30 12:30= OK
Eric 2 Mars 10:30 14:45= OK

Résultat attendu:

Paul 1 Mars 10:30 12:30
Paul 2 Mars 10:30 12:30
Eric 2 Mars 10:30 14:45

Merci pour le coup de main, A+

[mercatog]

bonjour,
regarde un sujet juste en dessous et adaptes http://www.developpez.net/forums/d87...ules-voisines/

[Gorfael]

Salut Albatros47 et le forum
Une proposition (non testée) :

Code :

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
Sub supprimeDoublons()
'Définitions ========================
Dim X As Long, Y As Long
Dim Flg As Boolean
'Traitement =========================
'Classement -------------------------
[A1].CurrentRegion.Sort Key1:=Range(MaCellule), Order1:=xlAscending, Header:=xlYes
'Suppression des doublons -----------
For X = Cells(Rows.Count, "A").End(xlUp).Row To 2 Step -1
'Pour X = n°dermière ligne utilisée en A, jusqu'à 2 en décrémentant
    If Range("A" & X) = Range("A" & X - 1) Then
    'Si A(x)=A(x-1) alors
        Flg = True
        'Drapeau à VRAI
        For Y = 2 To Cells(X, Columns.Count).End(xlToLeft).Column
        'Pour Y = 2 à n°dernière colonne utilisée dans la ligne X
            If Cells(X, Y) <> Cells(X - 1, Y) Then
            'si cellule en colonne Y, ligne X=ligne X-1, alors
                Flg = False
                'Drapeau à FAUX
                Exit For
                'sortir de la boucle
            End If
        Next Y
        If Flg Then Rows(X).Delete
        'si drapeau à vrai, supprimer la ligne X
    End If
Next X
End Sub

Quelques remarques sur les macros :
Tu utilises Select/Activecell => ça ne sert pas à grand chose et ne fait que ralentir ton code. Et dans ton cas, tu étais obligé de stocker la valeur de la cellule active, pour pouvoir la comparer.
Excel fait ça, parce qu'il est "bête", et enregistre chaque action.
Mais quand tu fais du code, tu peux pratiquement surprimer tout les tandems Select/Selection ou Select/Activecell, sans voir aucune modification (si ce n'est une accélération du traitement de la macro).

Dans mon code, je fais une boucle imbriquée (Y).
On peut remplacer

Code :

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
    If Range("A" & X) = Range("A" & X - 1) Then
    'Si A(x)=A(x-1) alors
        Flg = True
        'Drapeau à VRAI
        For Y = 2 To Cells(X, Columns.Count).End(xlToLeft).Column
        'Pour Y = 2 à n°dernière colonne utilisée dans la ligne X
            If Cells(X, Y) <> Cells(X - 1, Y) Then
            'si cellule en colonne Y, ligne X=ligne X-1, alors
                Flg = False
                'Drapeau à FAUX
                Exit For
                'sortir de la boucle
            End If
        Next Y
        If Flg Then Rows(X).Delete
        'si drapeau à vrai, supprimer la ligne X
    End If

par

Code :

1
2
3
4
5
6
    If Range("A" & X) = Range("A" & X - 1) Then
        If Cells(X, "B") = Cells(X - 1, "B") And _
           Cells(X, "C") = Cells(X - 1, "C") And _
           Cells(X, "D") = Cells(X - 1, "D") And _
           Cells(X, "E") = Cells(X - 1, "E") Then Rows.Delete
    End If

Mais, si tu as une vingtaine de colonnes, le code en devient moins lisible. Par contre, si tu as des heures inscrites de manière automatique, tu peux faire des arrondis :
12h30 est complêtement différent, pour Excel de 12h30 et 1 nanoseconde.
Pour moi, je vois 12h30 dans les deux (mais j'ai des lunettes )
A+

[Albatros47]

Bonsoir Gorfael et le forum,

J'ai testé ta solution, et un message d'erreur apparaît: "Methode range de l'objet global a échoué".

Peux-tu m'en dire un peu plus?

Merci pour le coup de main.

A+

[laetitia]

bonjour Albatros47 les amis Gorfael & mercatog le forum une autre approche .ayant "travaille" sur le sujet pendant quelques semaines j'ai mis au point une methode interessante en utilisant CreateObject("Scripting.Dictionary") & passer par des tablos quasi instantane sur 60000 lignes & sur 5 colonnes ce post me permet de la proposer pour la premiere fois a analyser!!!!

dans le cas de albatros je suppose que les donnees sont sur la colonne A a E autrement il faut adapter!!

Code :

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
Option Explicit
Dim t As Variant, t2() As String, m As Object, x As Long, i As Long, k As Long
Sub es()
       On Error Resume Next 'preferer une etiquette
      Application.ScreenUpdating = False
       Set m = CreateObject("Scripting.Dictionary")
       t = Range("a1:f" & Cells.Find("*", , , , , xlPrevious).Row)
       x = 1
       For i = LBound(t) To UBound(t)
       t(i, 6) = t(i, 1) & t(i, 2) & t(i, 3) & t(i, 4) & t(i, 5)
       If Not m.Exists(t(i, 6)) Then
       m.Add t(i, 6), t(i, 6)
       ReDim Preserve t2(1 To 5, 1 To x)
       For k = 1 To 5: t2(k, x) = t(i, k): Next k: x = x + 1:  End If: Next i
       Range("a1:e" & Cells.Find("*", , , , , xlPrevious).Row).ClearContents
       Range("a1").Resize(UBound(t2, 2), UBound(t2, 1)) = Application.Transpose(t2)
       Erase t, t2: Set m = Nothing
  End Sub

[Albatros47]

Bonsoir laetitia et le forum,

ça marche, que faudrait-il adapter pour respecter le format hh:mm en colonne D et E.

Déjà c'est une solution qui se rapproche énormément de ce que je voulais obtenir.

Un grand merci à tous.

A+

[laetitia]

re , donne plus explications !!! eventuellement un zip pour savoir excatemment ce que tu cherche a faire comme cela pas simple en general le format on le modifie a ce niveau du code un exemple au pire si pas de reponse je regarderais en fin de semaine peu de temps en ce moment a consacrer au forum sorry

Code :

t2(k, x) = Format(t(i, k), "0.00")

[Albatros47]

Bonsoir laetitia, bonsoir à tous,

Je joins un fichier afin de faire mieux comprendre ma demande.

Merci pour votre aide

Cordialement

[laetitia]

re, en regardant ton fichier tu veus pas supprimer les doublons !!! de plus tu tiens compte seulement des 3 premieres colonnes !!! & non 5
essai comme cela pour faire simple

Code :

1
2
3
4
5
6
7
8
9
10
11
12
13
14
Sub es()
 Dim m As Object, i As Long, z As Variant
    Application.ScreenUpdating = False
    Set m = CreateObject("Scripting.Dictionary")
    For i = 2 To Cells(Rows.Count, 1).End(xlUp).Row
      z = Cells(i, 1) & Cells(i, 2) & Cells(i, 3) '& Cells(i, 4) & Cells(i, 5)
            If Not m.Exists(z) Then
            m.Add z, z
            Cells(i, 6) = "ok"
       Else
          Cells(i, 6) = "doublons"
      End If
   Next i
End Sub

[Albatros47]

Bonjour à tout le forum,

Merci pour le temps que tu consacres à mon problème laetitia, je teste ta solution.

Cordialement.

JL

[Albatros47]

Bonsoir laetitia, bonsoir le forum,

Tu as répondu parfaitement à ma demande, merci pour le temps que tu as consacré à mon problème.

A+ sur le forum

Cordialement

JL