Code VBA pour faire un tri et supprimer doublons

Le 06/02/2019 à 09:13

bonjour le forum,

bonjour à tous,

je cherche un code VBA (à activer à partir d'un bouton) pour dresser une liste exhaustive d'articles.

1/il s'agit de copier la feuille SORTIES qui part des colonnes A à Q sur la feuille DONNEES.

2/une fois la copie faite, supprimer les colonnes de A à G + J et K.

3/faire un tri du plus petit au plus grand à partir de la colonne H

4/supprimer les lignes complètes des doublons des articles qui sont en colonne H

si possible en gardant la mise en forme source.

NB : la feuille SORTIES ne doit pas être modifiée.

merci d'avance pour votre aide experte.

cordialement.

69classeur1.xlsx (136.03 Ko)
Le 06/02/2019 à 10:53

Slt moutchec,

à tester.

Sub test()

Set Feuille = Worksheets("DONNEES")
lngLast = Feuille.Cells(Rows.Count, 2).End(xlUp).Row + 1

Sheets("SORTIES").Range("H:H, I:I, L:Q").Copy
Feuille.Cells(1, 1).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=True, Transpose:=False
Feuille.Columns("A:H").Sort Key1:=Range("A2"), Header:=xlYes

dligne = Range("A" & Rows.Count).End(xlUp).Row

    For ligne = dligne To 1 Step -1
        If WorksheetFunction.CountIf(Range("A2:A" & ligne), Range("A" & Zeile)) > 1 Then
            Rows(ligne).EntireRow.Delete
        End If
    Next
End Sub
Le 06/02/2019 à 12:10

Bonjour le fil, bonjour le forum,

Peut-être comme ça :

Sub Macro1()
Dim C As Worksheet 'déclare la variable C (onglet Copié)
Dim DL As Integer 'déclare la variable DL (Dernière Ligne)
Dim TV As Variant 'déclare la variable TV (Tableau des Valeurs)
Dim D As Object 'déclare la variable D (Dictionnaire)
Dim I As Integer 'déclare la variable I (Incrément)
Dim J As Integer 'déclare la variable J (incrément)
Dim K As Integer 'déclare la variable K (incrément)
Dim TMP As Variant 'déclare la variable TMP (tableau TeMPoraire)
Dim TL() As Variant 'déclare la variable TL (Taleau des Lignes)
Dim PL As Range 'déclare la variable PL (PLage)

Sheets("SORTIES").Copy After:=Sheets(Sheets.Count) 'copie l'onglet "SORTIES" en dernière position
Set C = ActiveSheet 'définit l'onglet copié C
C.Name = "Copie Sortie" 'renome l'onglet C
C.Columns("J:K").Delete Shift:=xlToLeft 'supprime les colonnes J et K
C.Columns("A:G").Delete Shift:=xlToLeft 'supprime les colonnes A à G
DL = C.Cells(Application.Rows.Count, "A").End(xlUp).Row 'définit la dernière ligne éditée DL de la colonne A de l'onglet C
C.Columns("A:H").Sort Key1:=Range("A2"), Header:=xlYes 'tri sur la colonne A
TV = C.Range("A1").CurrentRegion 'définit la tableau des valeur TV
Set D = CreateObject("Scripting.Dictionary") 'définit le dictionnaire D
For I = 2 To UBound(TV, 1) 'boucles sur toutes les lignes I du tableau des valeurs TV (en partant de la seconde)
    D(TV(I, 1)) = "" 'alimente le dictionnaire D avec les données de la colonne 1 du tableau des valeur TV
Next I 'prochaine ligne de la boucle
TMP = D.keys 'récupère dans le tableau temporaire TMP la liste des éléments du dictionnaire D sans doublons
For J = 0 To UBound(TMP) 'boucle 1 : sur tous les éléments du tableau temporaire TMP
    For I = 2 To UBound(TV, 1) 'boucles 2 : sur toutes les lignes I du tableau des valeurs TV (en partant de la seconde)
        If TV(I, 1) = TMP(J) Then 'condition : si la donnée ligne I colonne 1 du tableau des valeurs TV correspond à l'élément du tableau TMP
            ReDim Preserve TL(K) 'redimenssionne le tableau des lignes TL
            TL(K) = I 'récupère le numéro de la ligne I dans le tableau des lignes TL
            K = K + 1: Exit For 'incrémente K et sort de la boucle 2
        End If 'fin de la condition
    Next I 'prochaine ligne de la boucle 2
Next J 'prochain élément de la boucle 1
Set PL = C.Range("A1") 'initialise la plage PL
For I = 0 To UBound(TL) - 1 'boucle sur toutes les éléments du tableau des lignes TL (sauf le dernier)
    'si la ligne de TL(I) plus une et supérieure à la ligne de TL(I+1) mois une (pour au moins une ligne des doublons), redéfinit la plage PL
    If TL(I) + 1 < TL(I + 1) - 1 Then Set PL = IIf(PL.Cells.Count = 1, C.Rows(TL(I) + 1 & ":" & TL(I + 1) - 1), Application.Union(PL, C.Rows(TL(I) + 1 & ":" & TL(I + 1) - 1)))
Next I 'prochain élément de la boucle
PL.Delete 'supprime la plage PL
End Sub

[Édition]

@m3ellem1

Ton code ne fonctionne pas. Même en remplaçant Zeile par lngLast, ça met un temps fou et à la fin il ne reste qu'une seule ligne...

Le 06/02/2019 à 12:20

bonjour @m3ellem1 et merci bcp pour votre intervention.

le code fonctionne mais bug sur la ligne :

If WorksheetFunction.CountIf(Range("A2:A" & ligne), Range("A" & Zeile)) > 1 Then

au moment de supprimer les doublons.

merci.

Moutchec.

Le 06/02/2019 à 12:43

sorry

Sub test()

Set Feuille = Worksheets("DONNEES") 'définit l'onglet d'où on copie
lngLast = Feuille.Cells(Rows.Count, 2).End(xlUp).Row + 1 'définit la dernière ligne éditée del'onglet "DONNEES"

Sheets("SORTIES").Range("H:H, I:I, L:Q").Copy ' copier les colonnes souhaitées
Feuille.Cells(1, 1).PasteSpecial Paste:=xlPasteAll ' coller les colonnes copiées
Feuille.Columns("A:H").Sort Key1:=Range("A2"), Header:=xlYes 'tri sur la colonne A en négligeant Header
Feuille.Range("A1:H1").AutoFilter ' Filtrer les colonnes

dligne = Range("A" & Rows.Count).End(xlUp).Row ' définit la dernière ligne de ce qu'on a collé

    ' boucle pour éliminer les doublons
    For ligne = dligne To 1 Step -1
        If WorksheetFunction.CountIf(Range("A2:A" & ligne), Range("A" & ligne)) > 1 Then
            Rows(ligne).EntireRow.Delete
        End If
    Next
End Sub
Le 06/02/2019 à 13:25

Bonjour @ThauThème, @m3ellem1,

Deux solutions, deux générosités.... merci à vous deux.

Amicalement.

Moutchec.

Le 06/02/2019 à 13:57

Bonjour,

Une autre proposition.

Les données sont sous forme de tableaux.

Cdlt.

68moutchec.xlsm (143.63 Ko)
Public Sub Consolidate_data()
Dim ws As Worksheet, ws2 As Worksheet
Dim lo As ListObject, lo2 As ListObject
Dim tbl, arr()
Dim Cell As Range
Dim N As Long, I As Long, k As Long

    Set ws = Worksheets("SORTIES")
    Set ws2 = Worksheets("DONNEES")
    Set lo = ws.ListObjects(1)
    If Not lo.DataBodyRange Is Nothing Then
        N = lo.ListRows.Count
        Set lo2 = ws2.ListObjects(1)
        With lo2
            If Not .DataBodyRange Is Nothing Then .DataBodyRange.Delete
            Set Cell = .InsertRowRange.Cells(1)
        End With
        tbl = lo.Range.Value
        ReDim arr(N, 8)
        For I = 2 To UBound(tbl)
            arr(k, 0) = tbl(I, 8)
            arr(k, 1) = tbl(I, 9)
            arr(k, 2) = tbl(I, 12)
            arr(k, 3) = tbl(I, 13)
            arr(k, 4) = tbl(I, 14)
            arr(k, 5) = tbl(I, 15)
            arr(k, 6) = tbl(I, 16)
            arr(k, 7) = tbl(I, 17)
            k = k + 1
        Next I
        Cell.Resize(k, 8).Value = arr
        Application.ScreenUpdating = False
        With lo2
            .Sort.SortFields.Add lo2.ListColumns(1).DataBodyRange, xlSortOnValues, xlAscending
            .Sort.Apply
            .Sort.SortFields.Clear
            .Range.RemoveDuplicates Columns:=1, Header:=xlYes
        End With
    End If

End Sub
Le 06/02/2019 à 14:18

Bonjour le fil, bonjour le forum,

Après tests je me rend compte que le code de m3ellem1 est plus fiable que le mien qui laisse quelques doublons. Je l'ai modifié :

Sub test()
Set feuille = Worksheets("DONNEES") 'définit l'onglet d'où on copie
lngLast = feuille.Cells(Rows.Count, 2).End(xlUp).Row + 1 'définit la dernière ligne éditée del'onglet "DONNEES"

Sheets("SORTIES").Range("H:H, I:I, L:Q").Copy ' copier les colonnes souhaitées
feuille.Cells(1, 1).PasteSpecial Paste:=xlPasteAll ' coller les colonnes copiées
feuille.Columns("A:H").Sort Key1:=feuille.Range("A2"), Header:=xlYes 'tri sur la colonne A en négligeant Header
feuille.Range("A1:H1").AutoFilter ' Filtrer les colonnes
dligne = feuille.Range("A" & Rows.Count).End(xlUp).Row ' définit la dernière ligne de ce qu'on a collé
' boucle pour éliminer les doublons
For ligne = dligne To 1 Step -1
    If WorksheetFunction.CountIf(feuille.Range("A2:A" & ligne), feuille.Range("A" & ligne)) > 1 Then
        feuille.Rows(ligne).EntireRow.Delete
    End If
Next
End Sub
Le 06/02/2019 à 21:17

Bonjour @Jean-Eric,

j'essaye depuis cet après-midi de voir ce que donnerait mon fichier avec votre code mais ça bug sur la ligne :

Set lo = ws.ListObjects(1)

y a t'il une astuce pour que ça fonctionne en dehors du fichier exemple?

merci bcp.

Moutchec.

Le 06/02/2019 à 23:44

Bonjour,

Il faut mettre les données sous forme de tableaux structurés [Ruban : Mettre sous forme de tableau(ListObject)].

J'avoue ne plus savoir pour quelle raison, je suis parti pour construire un array !...

Cdlt.

Rechercher des sujets similaires à "code vba tri supprimer doublons"