Supprimer les doublons garder les lignes les plus complètes

JC -  
titeufdu89 Messages postés 374 Date d'inscription   Statut Membre Dernière intervention   -
Bonjour,

J'ai réunis plusieurs fichiers de participants à des evenements dans un seul fichier et il y a des doublons avec plusieurs lignes qui comportant la meme adresse email
Certaines lignes comportent juste l'adresse email, et d'autres avec le même email comporte aussi le nom, l'adresse, etc bref plus de renseignements et je souhaite conserver la ligne qui comporte le plus de renseignements evidemement
Or quand j'utilise la fonction "supprimer les doublons", la ligne qui est conservée est celle ou il n'y a que l'email, et les autres qui comportaient plein d'informations sont supprimées
Comment puis supprimer les doublons qui comportent le moins de renseignements ?
Merci par avance de votre aide



Configuration: Windows / Chrome 70.0.3538.110
A voir également:

2 réponses

titeufdu89 Messages postés 374 Date d'inscription   Statut Membre Dernière intervention   38
 
Bonjour,

Dans quelle colonne est contenue l'adresse mail?

Jc
0
titeufdu89 Messages postés 374 Date d'inscription   Statut Membre Dernière intervention   38
 
Voici un code qui permet d'épurer ta base en fonction de l'adresse mail :

Il faut simplement mettre à jour la partie du code :
col = 3 (et tu remplaces le 3 par l'adresse de la colonne qui contient tes adresses mail exemple colonne B = 2, colonne D = 4)

Option Explicit
Sub suppr_doublon()
Dim i As Long, mail As String, nb As Integer, j As Long, col As Integer
col = 3 '<<< à mettre à jour
For i = 1 To Cells(65536, col).End(xlUp).Row
    mail = Cells(i, col).Value
    nb = Application.WorksheetFunction.CountA(Range(Cells(i, 1), Cells(i, 100)))
        For j = Cells(65536, col).End(xlUp).Row To i + 1 Step -1
        If Cells(j, col).Value = mail Then
            If Application.WorksheetFunction.CountA(Range(Cells(j, 1), Cells(j, 100))) >= nb Then
            Rows(j).Copy Rows(i)
            nb = Application.WorksheetFunction.CountA(Range(Cells(j, 1), Cells(j, 100)))
            End If
        Rows(j).EntireRow.Delete
        End If
        Next j
Next i
End Sub


Ajoute ce code soit dans l'interface de la feuille qui contient ton tableau, soit dans un module, met à jour le code comme expliqué plus haut et exécute la macro pour épurer ta base.

Jc

0