Suppression des doublons sur 2 colonnes (1ère colonne= ok)

Bonjour,

Je souhaite améliorer ma macro VBA pour supprimer les doublons.

Il y a 3 colonnes:

"A" contient l'âge,

"B" contient le numéro.

"C" contient le produit.

Je souhaite supprimer le doublon en "B" et mettre les produits sur la même ligne (c'est-à-dire en colonne "C", "D", "E" etc.) pour les lignes que je supprime.

J'ai réussi à faire cette étape.

La deuxième condition est sur la colonne "A" qui contient la date de naissance.

1. si le doublon en "B" contient la même date de naissance en "A" (doublon en "A") donc je supprime le doublon.

2. mais si y a un doublon en "B" et la date de naissance en "A" est différente, alors ne pas supprimer.

En résumé je souhaite supprimer les doublons en "B" qui ont la même date de naissance en "A".

Exemple:

B2=B3=B4.

A2=A3 mais A4 a un numéro différent. Donc je voudrai supprimer le doublon en "B2" et "B3" et garder "B4".

Je voudrai comme résultat par exemple :

Garde les lignes 2 et 4.

Ci-joint un fichier avec mon code vba.

Merci pour votre aide précieuse.

Option Explicit

Private Sub SupprimerDoublons_Click()

Dim DerLig As Long, Ligne As Long

Dim C As Range

Application.ScreenUpdating = False

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

For Ligne = DerLig To 2 Step -1

If Application.CountIf(Range("B2:B" & DerLig), Range("B" & Ligne).Value) > 1 Then

Set C = Columns(2).Find(Range("B" & Ligne).Value, , xlValues, xlWhole, , xlNext)

If Not C Is Nothing Then

Range("C" & Ligne).Copy Cells(C.Row, 1).End(xlToRight).Offset(0, 1)

Rows(Ligne).Delete

End If

End If

Next Ligne

End Sub

Bonjour et bienvenue sur le forum

Si ton problème est toujours d’actualité, teste cette modification de ta macro qui ajoute une condition :

Option Explicit
Private Sub SupprimerDoublons_Click()
Dim DerLig As Long, Ligne As Long
Dim C As Range
    Application.ScreenUpdating = False
    DerLig = Range("A" & Rows.Count).End(xlUp).Row
    For Ligne = DerLig To 2 Step -1
        If Application.CountIf(Range("B2:B" & DerLig), Range("B" & Ligne).Value) > 1 Then
            Set C = Columns(2).Find(Range("B" & Ligne).Value, , xlValues, xlWhole, , xlNext)
            If Not C Is Nothing Then
                If Cells(Ligne, "A").Value = C.Offset(0, -1).Value And C.Row < Ligne Then
                    Range("C" & Ligne).Copy Cells(C.Row, 1).End(xlToRight).Offset(0, 1)
                    Rows(Ligne).Delete
                End If
            End If
        End If
    Next Ligne
End Sub
Bye !

Merci pour ton prgramme.

Il fonctionne très bien.

Bonne journée!