Supprimer lignes redondantes

[HUGS]

Bonjour tout le monde,

J'ai besoin d'une macro qui, selon la colonne de la cellule sélectionnée, supprime les lignes qui ont des valeurs redondantes ... ainsi dans cette colonne on ne pourra trouver plus d'une fois la m^me valeur une fois que la macro sera passée ...

j'mettais bidouillé ça mais ça marche plus :

Sub SupprimerLignesClé()

feuille_courante = ActiveSheet.Name
Application.ScreenUpdating = False
Application.DisplayAlerts = False
    With Worksheets(feuille_courante)
    
        ' N° de la colonne clé
        no_col_cle = ActiveCell.Column
        cle_courante = ""
        nb_suppressions = 0
        nb_lignes = 0
        
        ' Tri par clé
        .Cells(2, no_col_cle).Sort Key1:=.Cells(2, no_col_cle), _
            Order1:=xlAscending, Header:=xlGuess, _
            OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
        
    ' boucle identifiant le nbre de ligne
        nom_champ = 0
        For LigneTot = 2 To 65000
            nom_champ = .Cells(LigneTot, no_col_cle).Value
            If nom_champ = "" Then
                Exit For
            End If
        Next
        LigneTot = LigneTot - 1
        
 ValUn = Cells(2, no_col_cle).Value
        For Ligne = 3 To LigneTot
            nom_champ = .Cells(Ligne, no_col_cle).Value
            If nom_champ = ValUn Then .Cells(Ligne, no_col_cle).Value = ""
            If nom_champ <> ValUn Then ValUn = .Cells(Ligne, no_col_cle).Value
        Next
        
    
        ' Tri par clé
        .Cells(2, no_col_cle).Sort Key1:=.Cells(2, no_col_cle), _
            Order1:=xlAscending, Header:=xlGuess, _
            OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
        
    ' boucle identifiant le nbre de ligne avec valeurs
        nom_champ = 0
        For LignePleine = 2 To 65000
            nom_champ = .Cells(LignePleine, no_col_cle).Value
            If nom_champ = "" Then
                Exit For
            End If
        Next
        
If LignePleine - 1 <> LigneTot Then Range(Rows(LignePleine), Rows(LigneTot)).Select
If LignePleine - 1 <> LigneTot Then Selection.Delete
    
 Cells(2, no_col_cle).Select
    End With

Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub

=> j'ai du faire des boulettes ... mon plus gros défaut c'est que je dimensione mal les variables alors après ça passe pas partout ;(

J'ai mis un fichier test pour ceux qui veulent s'essayer à l'exercice ...

Par avance merci de votre aide.

HUGS

 

[Catrice]

Re : Supprimer lignes redondantes

Bonsoir,

Je propose ce code :

Sub Test()
With Sheets("Resultat")
    .Cells.Clear
    Sheets("Source").Range("A1").CurrentRegion.AdvancedFilter Action:=xlFilterCopy, CopyToRange:=.Range("A1"), Unique:=True
    .Select
End With
End Sub

Voir le fichier joint

 

[HUGS]

Re : Supprimer lignes redondantes

merci Catrice ...

mais la macro me laisse des doublons ...

en + il me faudrait que les lignes soient supprimées dans la feuille de travail ... (plutôt que filtrer et coller sur une autre feuille ...)

Merci de votre aide ...

 

[Catrice]

Re : Supprimer lignes redondantes

Bonjour,

Quels doublons laisse t elle ?
Sur quelle(s) colonne(s) faut-il dédoublonner ?
Si par exemple il faut dédoublonner sur la colonne 1, quelle ligne faut-il "sacrifier" ?

 

[HUGS]

Re : Supprimer lignes redondantes

merci Catrice .. finalement je me suis débrouillé en rendant plus robuste ma macro ...

elle doit être perfectible ...

ci-joint un fichier avec : une feuille "départ" et "arrivée" pour que tu visualises ce que je recherche à faire en supprimant les doublons de la colonne choisie ...

j'ai joint au fichier la macro qui désormais fonctionne ...

n'hésites pas à me faire tes commentaires ...

encore merci

A+

HUGS

 

[Catrice]

Re : Supprimer lignes redondantes

Bonsoir,

Pas trop regardé quels étaient les critères de suppression mais essaie le code suivant.
Voir le fichier joint

Sub Test()
If Selection.Column <= Range("IV1").End(xlToLeft).Column And Selection.Row <= Range("A65536").End(xlUp).Row Then
    Set MaZone = Selection.CurrentRegion
    MaCol = Selection.Column
    MaZone.Sort Key1:=Selection, Order1:=xlAscending, Header:=xlYes
    For i = MaZone.Rows.Count To 2 Step -1
        If Cells(i, MaCol) = Cells(i - 1, MaCol) Then Cells(i, MaCol).EntireRow.Delete
    Next
End If
End Sub

 

[HUGS]

Re : Supprimer lignes redondantes

Super Catrice !!! c'est pile ce que je recherchais : un bout de code bien robuste et monté différemment que le mien ...

Encore merci ...

A bientôt

HUGS