Aide sur l'extraction des doublons

Bonjour ,

j'ai une base des donnés des maladies cancéreuses sur excel ,contient plusieurs variables (représentés par les colonnes)et je voudrais extraire (couper ) les lignes doublons et les coller dans une autre feuille sachant que les doublons doivent être uniquement similaires aux noms(70%) ,prénoms (70%) et aux localisations (100%).

le variable noms est nommé NOMS

le variable prénoms est nommé PREN

le variable localisation est nommé LOC

un fichier exemple est dans la pièce jointe .

merci d'avance.

Bonjour Senouss,

Alors, de ce que j'ai compri :

• tu gardes quand même une copie du doublon dans ta première feuille
• les histoires de pourcentage, je vois pas trop d'où ça sortait...

Dans le doute, ce programme va considérer un doublon seulement si les noms, prénoms et localisations sont identiques :

Sub ExtractDoublon()
'By ReuK

Application.ScreenUpdating = False

Dim FeuillOrigine As String
Dim FeuillDest As String
'Ici tu mets le nom de tes feuilles
FeuillOrigine = "Feuil1"                    'à changer
FeuillDest = "Feuil2"                          'à changer

'Ici on va chercher la taille de ta base de données
Dim x As Long
x = Range("AA65536").End(xlUp).Row 'Ici si tu es sur Excel supérieur à 2003 je te conseille de mettre un chiffre plus grand 65536 , du genre 1000000 (pas beacoup plus!)

RangNom = "AA1" & ":" & "AA" & x
RangPrenom = "AB1" & ":" & "AB" & x
RangLoc = "I1" & ":" & "I" & x
RangTotal = "A1" & ":" & "AN" & x

'Là on va trier tes données pour faire un repérage des doublons plus rapide! (tri par nom, puis prénom, puis localisation)
    Sheets(FeuillOrigine).Activate
    ActiveWorkbook.Worksheets(FeuillOrigine).Sort.SortFields.Clear

    ActiveWorkbook.Worksheets(FeuillOrigine).Sort.SortFields.Add Key:=Range(RangNom), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    ActiveWorkbook.Worksheets(FeuillOrigine).Sort.SortFields.Add Key:=Range(RangPrenom) _
        , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    ActiveWorkbook.Worksheets(FeuillOrigine).Sort.SortFields.Add Key:=Range(RangLoc) _
        , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal

    With ActiveWorkbook.Worksheets(FeuillOrigine).Sort
        .SetRange Range(RangTotal)
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With

'On remet les entêtes dans ta feuille de destination
Dim m As Long
m = 1
Sheets(FeuillOrigine).Rows(1).Copy
Sheets(FeuillDest).Paste Destination:=Sheets(FeuillDest).Rows(m)
m = m + 1

'Et maintenant que c'est trié, on va balayer rapidement les données pour trouver les doublons!
For i = 2 To x
Sheets(FeuillOrigine).Activate

    If Sheets(FeuillOrigine).Cells(i, 27) <> Sheets(FeuillOrigine).Cells(i + 1, 27) Then
        Else
        If Sheets(FeuillOrigine).Cells(i, 28) <> Sheets(FeuillOrigine).Cells(i + 1, 28) Then
            Else
            If Sheets(FeuillOrigine).Cells(i, 9) <> Sheets(FeuillOrigine).Cells(i + 1, 9) Then
                Else
                    Sheets(FeuillOrigine).Rows(i + 1).Cut
                    Sheets(FeuillDest).Paste Destination:=Sheets(FeuillDest).Rows(m)
                    m = m + 1
            End If
        End If
    End If
Next i

'Là on va réorganiser les données pour éviter de laisser les blancs liés au couper coller (tri par nom, puis prénom, puis localisation)
    Sheets(FeuillOrigine).Activate
    ActiveWorkbook.Worksheets(FeuillOrigine).Sort.SortFields.Clear

    ActiveWorkbook.Worksheets(FeuillOrigine).Sort.SortFields.Add Key:=Range(RangNom), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    ActiveWorkbook.Worksheets(FeuillOrigine).Sort.SortFields.Add Key:=Range(RangPrenom) _
        , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    ActiveWorkbook.Worksheets(FeuillOrigine).Sort.SortFields.Add Key:=Range(RangLoc) _
        , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal

    With ActiveWorkbook.Worksheets(FeuillOrigine).Sort
        .SetRange Range(RangTotal)
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With

Application.ScreenUpdating = True
End Sub

Voilà, en espérant que c'est ce que tu voulais sinon, ça te fait déjà une base!

Bon courage!

MERCI