XL 2016 Suppression Doublons et Tri par Colonnes

[FAB80170]

Bonjour,

Je souhaite supprimer les doublons et trier par ordre croissant chaque colonnes individuellement sur une feuille unique.

Ma base contient plus de 30 000 lignes et plus de 30 colonnes et mon classeur plus de 20 onglets.

J'ai fourni un petit fichier pour exemple, avec des données et le résultat escompté (merci de tenir compte de l'execution sur une feuille unique).

Par avance merci.

 

[Compte Supprimé 979]

Bonjour Fab80170,

Un essai avec ce code ;-)

Sub SupDoublonsEtTri()
  Dim Col As Long, ColTmp As Long, NbCol As Long, NbLig As Long
  ' Dernière colonne
  NbCol = Cells(1, Columns.Count).End(xlToLeft).Column
  ' Numéro de la colonne temporaire
  ColTmp = NbCol + 1
  ' Pour chaque colonne
  For Col = 1 To NbCol
    ' Dernière ligne de la colonne
    NbLig = Cells(Rows.Count, Col).End(xlUp).Row
    ' Filtrer sans doublon
    Range(Cells(1, Col), Cells(NbLig, Col)).AdvancedFilter Action:=xlFilterInPlace, Unique:=True
    ' Copier les données dans la colonne temporaire
    Range(Cells(1, Col), Cells(NbLig, Col)).Copy Destination:=Cells(1, ColTmp)
    ' Supprimer le filtre
    On Error Resume Next
    ActiveSheet.ShowAllData
    On Error GoTo 0
    ' Effacer le contenu de la colonne
    Range(Cells(1, Col), Cells(NbLig, Col)).ClearContents
    ' Coller le résultat de la colonne temporaire
    Columns(ColTmp).Copy Destination:=Columns(Col)
    ' Effacer le contenu de la colonne temporaire
    Columns(ColTmp).ClearContents
    ' Trier le résultat
    With ActiveSheet.Sort
      .SortFields.Clear
      .SortFields.Add Key:=Columns(Col), _
        SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
      .SetRange Columns(Col)
      .Header = xlYes
      .MatchCase = False
      .Orientation = xlTopToBottom
      .SortMethod = xlPinYin
      .Apply
    End With
  ' Colonne suivante
  Next Col
End Sub

A+

 

[DoubleZero]

Bonjour, FAB80170, BrunoM45 , le Forum,

Une autre suggestion :

Option Explicit
Sub Doublons_supprimer_colonnes_trier()
    Dim c As Range
    With Application: .ScreenUpdating = False: .Calculation = xlManual: .EnableEvents = False: End With
    For Each c In Rows("1:1").SpecialCells(xlCellTypeConstants, 23)
        c.Select
        With Selection.EntireColumn
            .RemoveDuplicates Columns:=1, Header:=xlYes
            .Sort [Selection], Header:=xlYes
        End With
    Next
    Application.Goto Range("a1"), True
    With Application: .EnableEvents = True: .Calculation = xlAutomatic: .ScreenUpdating = True: End With
End Sub

A bientôt

 

[gosselien]

Bonjour,

si tu postes dans 2 forum et avec des réponses des 2 côtés, ça serait sympa de la faire savoir ...

P.

 

[FAB80170]

Bonsoir à tous.
Je rentre du boulot et n'ai pas pu vous remercier avant.
C'est juste génial !!!
Encore Merci !!!!!!!!!!!!!!
Respectueuse salutations.

 

[Staple1600]

Bonsoir à tous

la même que 00, les select en moins

Sub Doublons_supprimer_colonnes_trierNOSELECT()
Dim i&
With Application: .ScreenUpdating = False: .Calculation = xlManual: .EnableEvents = False: End With
For i = 1 To ActiveSheet.UsedRange.Columns.Count
    With Columns(i).EntireColumn
        .RemoveDuplicates Columns:=1, Header:=xlYes: .Sort .Range("A1"), Header:=xlYes
End With
Next
With Application: .EnableEvents = True: .Calculation = xlAutomatic: .ScreenUpdating = True: End With
End Sub

 

[Si...]

Salut

Pour éviter une indigestion d’endives à la mode de Staple dans le plat de ÓÒ

Sub SansDoublonsTri()
    Dim C As Range
    With Application: .ScreenUpdating = 0: .Calculation = xlManual: .EnableEvents = 0
     For Each C In ActiveSheet.UsedRange.Columns
       C.Columns.RemoveDuplicates 1, 1: C.Columns.Sort Cells(1, C.Column), Header:=1
     Next
    .EnableEvents = 1: .Calculation = xlAutomatic: .ScreenUpdating = 1: End With
End Sub