Discussion :

[Mimosa777]

Salut a tous,

J'ai besoin de votre aide pour formuler une macro qui ferait le travail que je fais d<habitude avec des formules (qui marche bien mais c'est long car a chaque fois je dois trier et creer des formules dans chaque case pour les identifier et ensuite le ssupprimer manuellement)

J'aimerais savoir si c'est faisable avec une macro, donc voila :

j'ai une feuille excel (voir fichier joint svp) avec deux onglets, la source et le resultat souhaite. J'aimerais que la macro fasse 2 choses :
1 - dans l'onglet "Source", Identifier les doublons en mettant la valeur de la colonne C en rouge(peu importe la couleur)
2 - afficher le resultat dans l'onglet "Resultats" - On supprime le/les doublons qui ne contiennent pas de valeur dans colonne E - Aussi, s'il y a un doublon qui possede 2 valeurs dans la colonne E, on prend le premier qu'on trouve et on supprime l'autre.

Si c'est pas clair, vous pourriez voir le resultat souhaite dans mon fichier joint.

Merci de votre aide - cette macro pour sauverait bcp de temps et de routine.

Merci

[Mimosa777]

Jai trouve cette formule qui fonctionne bien pour m'identifier les doublons :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
Sub IdentifieDoublons(Plage As Range)
    Dim Cell As Range
    Dim Un As Collection
 
    Set Un = New Collection
 
    On Error Resume Next
 
    'Boucle sur la plage de cellule
    For Each Cell In Plage
        'Pour ne pas prendre en compte les cellules vides
        If Cell <> "" Then
            'Ajoute le contenu de la cellule dans la collection
            Un.Add Cell, CStr(Cell)
 
            'Si la procédure renvoie une erreur, cela signifie que l'élément
            'existe déjà dans la collection et donc qu'il s'agit d'un doublon.
            'Dans ce cas la macro colorie la cellule en vert.
            If Err <> 0 Then Cell.Interior.ColorIndex = 4
            'Efface toutes les valeurs de l'objet Err.
            Err.Clear
        End If
    Next Cell
 
    Set Un = Nothing
End Sub

Maitenent comment afficher dans l'onglet Resultat les valeurs uniques seulement avec leur valeur de la colonne E. Merci de votre aide

[mercatog]

A partir d'Excel 2007, tu peux utiliser RemoveDuplicate

Ci-joint macro adaptée à partir de l'enregistreur de macros

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
Sub Macro1()
Dim LastLig As Long
 
Application.ScreenUpdating = False
Worksheets("Resultats").UsedRange.Clear
With Worksheets("Source")
    LastLig = .Cells(.Rows.Count, "A").End(xlUp).Row
    .Range("A1:E" & LastLig).Copy Worksheets("Resultats").Range("A1")
End With
With Worksheets("Resultats")
    .Range("A1:E" & LastLig).Sort Key1:=.Range("E2"), Order1:=xlDescending, Header:=xlYes
    .Range("A1:E" & LastLig).RemoveDuplicates Columns:=3, Header:=xlYes
    .Range("A1:E" & LastLig).Sort Key1:=.Range("C2"), Order1:=xlAscending, Header:=xlYes
End With
End Sub

[Mimosa777]

Oh merci enormement mercatog.

Mercatog, j'essaie de modifier ton code pour changer les colonnes de selection. Quand j'essaie d'appliquer la macro sur la colonne commencant de U a Z, ca marches pas.. Pourtant je change bien dans ta macro comme suit :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
Dim LastLig As Long
 
Application.ScreenUpdating = False
Worksheets("NoDuplicates").UsedRange.Clear
With Worksheets("RDB")
    LastLig = .Cells(.Rows.Count, "D").End(xlUp).Row
    .Range("U2:Z" & LastLig).Copy Worksheets("NoDuplicates").Range("A2")
End With
With Worksheets("NoDuplicates")
    .Range("U2:Z" & LastLig).Sort Key1:=.Range("Z2"), Order1:=xlDescending, Header:=xlYes
    .Range("U2:Z" & LastLig).RemoveDuplicates Columns:=3, Header:=xlYes
    .Range("U2:Z" & LastLig).Sort Key1:=.Range("W2"), Order1:=xlAscending, Header:=xlYes
End With

Dois je tenir compte d'autres choses ?

[mercatog]

Quand tu copies les données de U..Z vers la feuille NoDuplicates en A2, la suppression des doublons se fait dans cette feuille de A à F.
Il fallait adapter après avoir compris

Ci-joint code commenté à adapter sur ton fichier

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
Dim LastLig As Long
 
Application.ScreenUpdating = False
Worksheets("NoDuplicates").UsedRange.Clear
With Worksheets("RDB")
    'Ici on prends la colonne D comme référence pour chercher la ligne de la dernière cellule remplie de la feuille RDB
    LastLig = .Cells(.Rows.Count, "D").End(xlUp).Row
    'Tu copies   les colonnes U à Z de RDB vers A2 de NoDuplicates
    .Range("U2:Z" & LastLig).Copy Worksheets("NoDuplicates").Range("A2")
End With
 
'Désormais en travaille après copie sur la feuille NoDuplicates
'Avec Colonne C: Là où on cherche les doublons legacy #
'Colonne F: C'est la colonne PMX
 
With Worksheets("NoDuplicates")
    .Range("A2:F" & LastLig).Sort Key1:=.Range("F2"), Order1:=xlDescending, Header:=xlNo
    .Range("A2:F" & LastLig).RemoveDuplicates Columns:=3, Header:=xlNo
    .Range("A2:F" & LastLig).Sort Key1:=.Range("C2"), Order1:=xlAscending, Header:=xlNo
End With