Optimisation code : suppression doublon

Le 31/03/2020 à 19:33

Bonjour,

J'ai une colonne qui comporte des cellules qui peuvent avoir les mêmes valeurs. Je souhaite conserver uniquement la 1er valeur et supprimer les doublons.

J'ai trouvé un bout de code qui fonctionne très bien, mais qui je trouve est un peu long à s’exécuter.

Je vous mets le fichier en pj.

Si vous aviez une idée pour l'améliorer.

Merci d'avance.

20classeur1.xlsm (16.70 Ko)
Le 31/03/2020 à 21:08

Bonsoir Falckner, bonsoir le forum,

Essaie comme ça :

Sub Macro1()
Dim O As Worksheet 'déclare la variable O (Onglet)
Dim PL As Range 'déclare la variable PL (PLage)
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)

Set O = Worksheets("Feuil1") 'définit l'onglet O
Set PL = O.Range("A1").CurrentRegion 'définit la plage PL
TV = PL 'défnit le tableau des valeurs TV
Set D = CreateObject("Scripting.Dictionary") 'définit le dictionnaire D
For I = 1 To UBound(TV, 1) 'boucle sur toutes les lignes I du tableau des valeurs TV
    'si la donnée ligne I colonne 1 de TV est répétée au moins une fois, alimente le dictionnauire D avec cette donnée
    If Application.WorksheetFunction.CountIf(PL, TV(I, 1)) > 1 Then D(TV(I, 1)) = ""
Next I 'prochaine ligne de la boucle
If D.Count > 1 Then 'condition : si il existe au moins un élément du dictionnaire D
    PL.ClearContents 'efface le contenu de la plage PL
    'renvoie dans A1 redimensionnée la liste transposée des éléments du dictionnaire D sans doublons
    O.Range("A1").Resize(D.Count, 1).Value = Application.Transpose(D.keys)
End If 'fin de la condition
End Sub
Le 01/04/2020 à 03:35

Bonjour,

Si je ne me trompe pas, Excel conserve le premier élément.

j'ai inhibé le tri.

A tester.

Cdlt.

Public Sub KeepDuplicate()
Dim lastRow As Long, rng As Range
    With ActiveSheet
        lastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
        Set rng = .Cells(1).Resize(lastRow)
        With rng
            '.Sort rng.Cells(1), xlAscending
            .RemoveDuplicates 1
        End With
    End With
End Sub
Le 01/04/2020 à 11:08

Bonjour et Merci à tous les deux .

Vos macros fonctionnement très bien, mais j'ai mal du m'exprimer. Je souhaite effacer les données en doublon et conserver les autres à la même position .

Ma macro donne le résultat que je souhaite . Ce que je voulais savoir, c'est si on peut l'optimiser pour passer de 20 lignes de codes à 5 .

J'ai mis un nouveau fichier en intégrant vos deux macros .

4classeur1.xlsm (27.21 Ko)
Le 01/04/2020 à 11:28

Bonjour,

Une mise à jour !...

Cdlt.

5classeur1-1.xlsm (27.86 Ko)
Public Sub KeepDuplicate3()
Dim lastRow As Long, rng As Range, tbl, i As Long, vString
    With ActiveSheet
        lastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
        'Set rng = .Cells(1).Resize(lastRow)
        'rng.Sort rng.Cells(1), xlAscending
        tbl = .Cells(1).Resize(lastRow)
        vString = tbl(1, 1)
        For i = 2 To UBound(tbl)
            If tbl(i, 1) = vString Then
                tbl(i, 1) = vbNullString
            Else
                vString = tbl(i, 1)
            End If
        Next i
        'rng.Value = tbl
        .Cells(1).Resize(lastRow) = tbl
    End With
End Sub
Le 01/04/2020 à 11:33

Re,

C'est cool ce que tu as fait pour qu'on puisse tester... Essaie comme ça :

Sub Macro1()
Dim O As Worksheet 'déclare la variable O (Onglet)
Dim PL As Range 'déclare la variable PL (PLage)
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 K As Integer 'déclare la variable K (incrément)
Dim TMP As Variant 'déclare la variable TMP (tabeau TeMPoraire)
Dim TL() As Variant 'déclare la variable TL(Tableau des Lignes)

Set O = Worksheets("Feuil1") 'définit l'onglet O
Set PL = O.Range("A1").CurrentRegion 'définit la plage PL
TV = PL 'défnit le tableau des valeurs TV
Set D = CreateObject("Scripting.Dictionary") 'définit le dictionnaire D
For I = 1 To UBound(TV, 1) 'boucle sur toutes les lignes I du tableau des valeurs TV
    'conditoin 1 : si la donnée ligne I colonne 1 de TV est répétée au moins une fois, alimente le dictionnaire D avec cette donnée
    If Application.WorksheetFunction.CountIf(PL, TV(I, 1)) > 1 Then
        If Not D.Exists(TV(I, 1)) Then 'condition 2 : si l'élément n'existe pas dans le dictionnaire D
            ReDim Preserve TL(K) 'redimensione le tableau des lignes (K lignes)
            TL(K) = I 'récupère le numéro de ligne dans la donnée K du tableau des lignes TL
            K = K + 1 'incrémente K
        End If 'fin de la condition 2
        D(TV(I, 1)) = "" 'ajoute l'élément au dictionnaire D
    End If 'fin de la condition 1
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 doublon
If D.Count > 1 Then 'condition : si il existe au moins un élément du dictionnaire D
    PL.ClearContents 'efface le contenu de la plage PL
    For I = 0 To UBound(TL) 'boucle sur touts les élément du tableu des lignes TL
        O.Cells(TL(I), "A") = TMP(I) 'renvoie dans la cellule ligne TL(I), colonne A la valeur de TMP(I)
    Next I 'prochaine ligne d ela boucle
End If 'fin de la condition
End Sub

[Édition]

Pfff... Trop fort de Jean-Éric...

Le 01/04/2020 à 12:56

Super ! Les deux macros fonctionnent comme je le souhaite .

Je regarde d'un peu plus près pour mieux les comprendre.

Rechercher des sujets similaires à "optimisation code suppression doublon"