Résolu Excel bouton suppression de doublon avec condition

[spooty67]

Bonjour,

J'ai de nouveau besoin de votre précieuse aide pour une macro que j'effectue. J'ai fait un bouton avec une macro qui supprime les doublons. La formule fonctionne, cependant, j'aimerais pouvoir y mettre une condition pour que la ligne gardée soit la bonne.

Ma macro est la suivante :

Option Explicit
Option Base 1
 
Sub SupprimeDoublons()
    Dim Plage As Range, Cell As Range
    Dim Un As New Collection
    Dim Tableau() As Integer
    Dim x As Integer
 
 
    Set Plage = Worksheets("Sheet1").Range("A1:A500")
 
    On Error Resume Next
        For Each Cell In Plage
        Un.Add Cell, CStr(Cell)
 
        If Err.Number <> 0 Then
            x = x + 1
            ReDim Preserve Tableau(1 To x)
            Tableau(x) = Cell.Row
            Err.Clear
        End If
    Next Cell
    On Error GoTo 0
     If x = 0 Then Exit Sub
 
    Application.ScreenUpdating = False

    For x = UBound(Tableau) To LBound(Tableau) Step -1
        Worksheets("Sheet1").Rows(Tableau(x)).EntireRow.Delete
    Next x
 
    Application.ScreenUpdating = True
End Sub

J'aimerais pouvoir ajouter une condition qui dit que la ligne gardée doit être celle qui a, dans la colonne 6, la valeur la plus grande.

J'espère avoir été assez clair dans mon explication et vous remercie par avance pour votre aide !

Meilleures salutations.

Stefan

 

[drul]

Salut, la méthode utilisé pour trouver les doublons est amusante et astucieuse

Par contre elle ne facilite pas la tâche pour ton besoin :/
Mais bon, on va quand même y arriver
Ce qu'il faut faire:
1) lors d'une erreur : comparer la valeur de la colonne 6 de la cellule stockée et celle de la cellule en cours
2) si la cellule en cours est plus petite pas de problème, on la mais de le tableau des cellule à supprimer
3) sinon, il faut mettre la cellule stocké dans le tableau, la supprimé de la collection et ensuite stocké la cellule actuelle.

Ok maintenant on a un tableau contenant toute les lignes à supprimé, MAIS dans le désordre ! si on fait la suppression direct, c'est la cata assuré ...

Donc 2 solutions ici:

soit: on trie le tableau AVANT d'effectuer l'effacement (on trouve plein de routine quicksort sur le net)
soit: bien plus simple et rapide, on utilise la fonction UNION pour créer une RANGE contenant toutes les lignes à supprimer (et la pas besoin de le faire dans l'ordre) et on efface tout d'un coup.

Tu veux essayer par toi-même (ce serait bien) ou je te file direct la soluce ?

 

[spooty67]

Hello drul,

Merci encore pour ta précieuse aide et conseil.

J'ai essayé de trouver une solution avec Range, mais je dois t'avouer que je rame. J'ai visiblement un souci de compréhension sur la manière de l'utiliser et de comment l'implémenter dans ma formule de base.

Si tu as plus simple et plus efficace, je suis preneur !

Merci encore pour ton aide et toute bonne semaine.

 

[drul]

Regarde ceci

Sub SupprimeDoublons()
    Dim Plage As Range, Cell As Range
    Dim Un As New Collection
    Dim Tableau() As Integer
    Dim x As Integer
    Dim toErase As Range
 
    Set Plage = Worksheets("Sheet1").Range("A1:A11")
 
    On Error Resume Next
        For Each Cell In Plage
        Un.Add Cell, CStr(Cell)
 
        If Err.Number <> 0 Then
                x = x + 1
                ReDim Preserve Tableau(1 To x)
            If Cell.Offset(0, 5).Value <= Un.Item(CStr(Cell)).Offset(0, 5).Value Then ' si la cell en cours est <= à la cell stocker
                Tableau(x) = Cell.Row ' on supprime la cell en cours
            Else 'sinon, onsupprime la cell stock et on la remplace dans la collection
                Tableau(x) = Un.Item(CStr(Cell)).Row
                Un.Remove CStr(Cell)
                Un.Add Cell, CStr(Cell)
            End If
            
            Err.Clear
        End If
    Next Cell
    On Error GoTo 0
     If x = 0 Then Exit Sub
 
    'Application.ScreenUpdating = False '- inutile on efface tout d'un coup maintenant
 
    For x = UBound(Tableau) To LBound(Tableau) Step -1 'on pourrait très bien faire la boucle à l'endroit ...
        If toErase Is Nothing Then 'Si la range à effacer est vide, on l'initialise
            Set toErase = Worksheets("Sheet1").Rows(Tableau(x)).EntireRow
        Else 'sinon on la complète
           Set toErase = Union(toErase, Worksheets("Sheet1").Rows(Tableau(x)).EntireRow)
        End If
    Next x
    toErase.Delete 'et finalement on détruit toue les cellules d'un coup
    'Application.ScreenUpdating = True
End Sub

 

[spooty67]

J'ai essayé ton code, cependant, je dois avoir enlevé quelque chose ou adapté quelque chose de faux dans mon fichier, car quand j'utilise ma macro, sur un test de 4 lignes dont 2 fois un doublon sur la première colonne mais une différence de nombre sur la colonne 6, il m'en enlève trois au lieu de deux...

Voilà comment j'ai essayé d'adapter le code que tu m'as indiqué :

Option Explicit
Option Base 1
 

Sub SupprimeDoublons()
    Dim Plage As Range, Cell As Range
    Dim Un As New Collection
    Dim Tableau() As Integer
    Dim x As Integer
    Dim toErase As Range
 
    Set Plage = Worksheets("Base de données").Range("A1:A500")
 
    On Error Resume Next
        For Each Cell In Plage
        Un.Add Cell, CStr(Cell)
 
        If Err.Number <> 0 Then
                x = x + 1
                ReDim Preserve Tableau(1 To x)
            If Cell.Offset(0, 5).Value <= Un.Item(CStr(Cell)).Offset(0, 5).Value Then
                Tableau(x) = Cell.Row
            Else
                Tableau(x) = Un.Item(CStr(Cell)).Row
                Un.Remove CStr(Cell)
                Un.Add Cell, CStr(Cell)
            End If
 
            Err.Clear
        End If
    Next Cell
    On Error GoTo 0
     If x = 0 Then Exit Sub
 
        For x = UBound(Tableau) To LBound(Tableau) Step -1
        If toErase Is Nothing Then
            Set toErase = Worksheets("Base de données").Rows(Tableau(x)).EntireRow
        Else
           Set toErase = Union(toErase, Worksheets("Base de données").Rows(Tableau(x)).EntireRow)
        End If
    Next x
    toErase.Delete
    Application.ScreenUpdating = True
End Sub

Par ailleurs, je t'avoues que là, je commence sincèrement à me perdre, c'est top de pouvoir faire tout ça, mais j'arrive plus vraiment à suivre avec les différents codes. Je crois que j'ai bien besoin d'un cours moi

Merci en tout cas pour toute l'aide apportée jusqu'à présent, j'apprécie vraiment !

 

[drul]

Ta sixième colonne c'est bien la colonne F ?
Tu peux me mettre un printscreen de tes données ?

 

[spooty67]

Oui, c'est bien la F.

Pour le printscreen, je veux bien mais il faudrait que ce soit un mp, car il y a des données confidentielles (Travail). Je te l'envoie de ce pas

 

[drul]

Étrange ça fonctionne bien sur mon test ...
Tu peux mettre un breakpoint ici: "Tableau(x) = Un.Item(CStr(Cell)).Row"
et voir si le programme s'y arrête ?

 

[drul]

Salut, j'ai regarder ton fichier.
J'avais pas saisi que les chiffres en F était stocker sous forme de texte.
Essaye de remplacer:
If Cell.Offset(0, 5).Value <= Un.Item(CStr(Cell)).Offset(0, 5).Value Then
par:
If val(Cell.Offset(0, 5).Value) <= val(Un.Item(CStr(Cell)).Offset(0, 5).Value) Then

 

[spooty67]

Hello drul,

Merci beaucoup !!!

C'est parfait ! ça fonctionne comme sur des roulettes !

Bonne fin de semaine et meilleures salutations.

 

[drul]

Stp clos le sujet