Discussion :

[morguie31]

Bonjour

étant débutante en VBA, vous êtes mon unique chance de parvenir à réaliser ce travail..
Je vous explique, j'ai un extrait (200 lignes) d'une base de données. J'ai pour mission de supprimer les doublons. Rapidement on remarque qu'il existe plusieurs lignes d'une même société, parfois avec une adresse identique (cas 1), parfois avec une adresse différente (cas 2).
Dans le cas 1, il s'agirait de garder la ligne qui contient le plus d'informations importantes (n° de téléphone, mail, nom du contact, adresse, ...)
Dans le cas 2, il s'agirait de conserver de tout car on considèrerait alors qu'il s'agit de lignes bien distinctes.
Je joins à ce message l'extrait en question en espérant grandement que quelqu'un pourra me sauver
Merci d'avance !
Morgane

[patricktoulon]

bonjour Morganne

comme ca vite fait je vois 2 boucle imbriquée
la premier boucle sur tout les nom
la deuxieme boucle sur les nom et les addresses
en comparant nom et adresse on supprime les adresse en double
exemple vite fait et regarde les commentaire dans le code c'st plus qu'important

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
27
28
29
30
31
32
33
34
35
36
37
38
39
 
Dim nom As String, adresse As String, i As Long, e As Long    ' declaration des variable
    Sub tri_les_doublon_par_le_nom_et_les_adresse()
 
    ' on apelle la verif des espaces apres la derniere lettre du nom  avant de faire le tri
   Application.ScreenUpdating = fase    ' pour eviter de voir syntiller ton ecran
     verification_des_espaces_apres_les_noms
 
    For i = 2 To Range("d" & Rows.Count).End(xlUp).Row    '1 ere boucle sur la colonne des nom
 
        nom = Cells(i, "d")    'a chaque tour de boucle la variable nom prend la valeur de la celulle"D" en ligne "i"
        adresse = Cells(i, "d").Offset(0, 1)    'a chaque tour de boucle la variable adresse prend la valeur de la celulle"e" en ligne "i"
 
        For e = 3 To Range("d" & Rows.Count).End(xlUp).Row    '2eme boucle sur la colonne"d"
'1ere condition
'si la cellule "D" en ligne e =  nom et celle d'a coté a droite = adresse
            If Cells(e, "d").Value = nom And Cells(e, "d").Offset(0, 1).Value = adresse Then
                '2eme Condition
                'si la ligne e est differnete de i alors on supprime la ligne
                If Cells(e, "d").Row <> Cells(i, "d").Row Then
                    Cells(e, "d").EntireRow.Delete
                End If
            End If
        Next e
    Next i
End Sub
' ATTENTION' ATTENTION' ATTENTION' ATTENTION' ATTENTION' ATTENTION' ATTENTION' ATTENTION
' ATTENTION L'ORS DE L'ESSAI DE MA MACRO IL Y AVAIT DES ERREURS POUR LA SIMPLE ET BONNE RAISON QUE LES NOM MEME SI IL ONT L'AIR PAREIL
'il y a un espace qui sui le nom sur certains nom identique alors forcement il est pris comme différent
 
'exemple:
 
'"toto"
'"toto "
' alors avant de faire le tri on verifie les espaces apres la derniere lettre du nom
Function verification_des_espaces_apres_les_noms()
For i = 2 To Range("d" & Rows.Count).End(xlUp).Row
If Right(Cells(i, "d"), 1) = " " Then Cells(i, "d") = Left(Cells(i, "d"), Len(Cells(i, "d")) - 1)
Next

encore une fois fait attention au espaces qui suivent les nom dans les cellules bien que maintenant la macro se charge de corriger le probleme

au plaisir

[morguie31]

bonjour et merci bcp pour cette solution !

cela fonctionne bien et j'en suis ravie !
maintenant, penses tu qu'il serait possible que la macro puisse comparer les adresses 1, 2 et 3 pour éviter les doublons sur ce point la ?

merci encore !
au plaisir

Morgane

ou alors, ne serait ce pas intéressant de trier suivant la date de création de la ligne ?
si j'ai deux lignes concernant la société X, ayant la même adresse, préférer de concerver la ligne ayant été créée en dernier ? la plus récente quoi...
Merci !

[patricktoulon]

bonjour morganne

oulala ne t'emballe pas je n'etait pas sur ton fichier la

de toute facon a mon avis c'est possible

de comparer les adresse 1,2,3

maintenant pour les dates je n'est pas ton fichier sous les yeux je vais regarder

maintenant a tu compris au moins quelque chose dans ce code

car l'interet du forum c'est pas de faire ton travail mais de t'aider

je regarde ca et je reviens plus tard

au plaisir

[morguie31]

oui oui je pense l'avoir à 75 % compris (les 25 % restant, je vais les bucher !) j'apprends énormément !
c'est vraiment très gentil, merci !

[patricktoulon]

re

ton fichier c'est un foutoir je ne sais pas qui le rempli mais y aucune rigueur

les nom identique peuvent avoir des accents ou pas ce qui rend la macro inoperente de ce coté la puisque le moindre caracvtere different rend la valeur unique

ensuite les espaces ou non a lafin des nom et adresse

non vraiment

en vba on peut faire beaucoup de chose mais excel ne devine pas

bon je continu je crois avoir une solution mais amon avis la macro ne fonctionnera pas longtemps si tu continu a remplir tes lignes de la meme maniere alors je pense que pour le bien de tous et surtout le peu de cheveux qu'il me reste je transformer tout les noms en majuscule de facon a ce qu'il n'y est plus d'accent ect.....

a tu compris

avec ton niveau en vba et un tableau pareil tu n'y serait jamais arrivé

bon ma crise est passé je reviens avec une new version

au plaisir

[morguie31]

et oui, j'avoue que c'est vraiment le bazard! ce n'est pas moi qui l'ai rempli sinon, je peux dire qu'il serait bcp mieux renseigné !

merci encore et infinimment

morgane

[patricktoulon]

bonsoir morganne

je me suis pencher sur la question mais il y a vraiment trop invraisenblance

des diferences d'accents
des diferences d'espaces
des diferences (1 point a la fin d'autre non)
des diference (un tiret d'autre non)

non dans l'etat c'est un travail de cochon

en attendant voila un model de macro
si il n'y avais pas toutes ces erreurs elle fonctionnerait a merveille

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
27
28
29
30
31
32
33
34
35
36
37
38
39
 
Sub essai_27()
    Application.ScreenUpdating = False
    Dim nom(500) As Variant, adresse1(500) As Variant, adresse2(500) As Variant
    Dim fin As Long
    caractere = Array("é", "à", "è", "ç")
    caracterebis = Array("e", "a", "e", "c")
    fin = Range("d" & Rows.Count).End(xlUp).Row
    For i = 2 To fin
        If Right(Cells(i, "d"), 1) = " " Then Cells(i, "d") = Left(Cells(i, "d"), Len(Cells(i, "d")) - 1)
        If Right(Cells(i, "d"), 1) = "  " Then Cells(i, "d") = Left(Cells(i, "d"), Len(Cells(i, "d")) - 2)
 
        If Right(Cells(i, "d"), 1) = "." Then Cells(i, "d") = Left(Cells(i, "d"), Len(Cells(i, "d")) - 1)
        If Right(Cells(i, "d"), 1) = ". " Then Cells(i, "d") = Left(Cells(i, "d"), Len(Cells(i, "d")) - 2)
        If Right(Cells(i, "e"), 1) = " " Then Cells(i, "e") = Left(Cells(i, "e"), Len(Cells(i, "e")) - 1)
        If Right(Cells(i, "f"), 1) = " " Then Cells(i, "f") = Left(Cells(i, "f"), Len(Cells(i, "f")) - 1)
        For car = 0 To 3
            'on remplace les caractere avec accents et on met em majuscule les variables  adresse pour pouvoir les comparer
            Cells(i, "e") = Replace(Cells(i, "e"), caractere(car), caracterebis(car))    'a chaque tour de boucle la variable adresse prend la valeur de la celulle"e" en ligne "i"
            Cells(i, "f") = Replace(Cells(i, "f"), caractere(car), caracterebis(car))    'a chaque tour de boucle la variable adresse prend la valeur de la celulle"f" en ligne "i"
 
        Next
        nom(i) = UCase(Cells(i, "d"))
        adresse1(i) = UCase(Cells(i, "e"))
        adresse2(i) = UCase(Cells(i, "f"))
    Next
  For a = 2 To fin
        For Z = 3 To fin
            DoEvents
            If nom(Z) = nom(a) And adresse1(Z) = adresse1(a) And adresse2(Z) = adresse2(a) Then
                If Z <> a Then Rows(Z & ":" & Z).Delete
            End If
        Next Z
    Next a
 
    nom(500) = ""
    adresse1(500) = ""
    adresse2(500) = ""
End Sub

essai d'en comprendre un minimum sinon tu va te perdre

au plaisir

pour te donner une idée du foutoir dans ton sheets

regarde si il etait mieux renseigné comment on procederait

Code :

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

1
2
3
4
5
 
Sub essai29()
   ActiveSheet.Range("$D$1:$F$200").RemoveDuplicates Columns:=Array(1, 2, 3), _
        Header:=xlYes
End Sub

2 ligne de code et c'est tout
que dije 2 lignes non une seule suffira

Code :

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

ActiveSheet.Range("$D$2:$F$200").RemoveDuplicates Columns:=Array(1, 2, 3)

au plaisir

[Montor]

je voulait bien te demander que une solution native belle est bien existe

[patricktoulon]

bonsoir montor


oui c'est sur mais quand on regarde son fichier la macro utilisant les fonctions native enlève 12 lignes

sur 200 et dans ce cas de figure il faut en enlever 64 ça te donne une idée du foutoir sur l'orthographe des nom et adresses surtout sur a peine 200 lignes

c'est pour ça que je me suis lancé dans cette moulinette

on pourrait de toute façon y arriver mais la moulinette se transformerait en bourrin


au plaisir

[morguie31]

bonjour

j'ai pu revoir un peu tout ça, merci bcp c'est génial, je vais pouvoir commencer à bosser sérieusement la dessus.
très bonne journée à toi
merci encore !

Morgane

[patricktoulon]

bonjour morganne

dans une autre discussion traitant un peu le meme sujet
mercatog a apporté une idée est un raisonnement sur le calcul de similarité entre deux mots un peu comme le dictionnaire te propose des options quand tu tape une faute dans un texte sur world et autre applications

un autre forumeur(oliv+-) a retrouver ce petit bijoux de fonction

je l'ai donc adapté cette fonction a ton souci

du coup en une seule fois non seulement tu tris les doublons sur 3 colonnes en l'occurrence ("d,e,f")mais tu prend en compte meme les mots qui ont une faute ou mal écrit a condition de demander un indice raisonnable afin de ne pas supprimer des bonnes lignes

sachant que pour les nom l'indice le plus fort est 1 j'ai mis 0,9 et pour les adresses j'ai mis un peu plus bas au cas ou il y aurais un dyslexique qui ai rempli la liste

donc tu peux remercier mercatog et oliv+- pour ce petit bijoux je n'est fait que de l'adaptation a ton cas

voila le code adapté a ton cas
met le tout dans un module standard et lance la macro "trillage"

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
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
 
Option Explicit
 
Public Function NOMSIMILAIRE(ByVal s1 As String, ByVal s2 As String) As Single
'Calcul la similarité (de [0 à 1]) entre deux chaines d'après l'algorithme de Damerau-Levenshtein
'références : http://en.wikipedia.org/wiki/Damerau%E2%80%93Levenshtein_distance
'             http://mwh.geek.nz/2009/04/26/python-damerau-levenshtein-distance/
'             http://www-igm.univ-mlv.fr/~lecroq/seqcomp/node2.html
'Remarques  : Préparer les chaines car les comparaisons sont binaires : UCase(), Trim(),...
'Philben v1.0 - Free to Use
    Const cFacteur As Long = &H100&, cMaxLen As Long = 256&   'Longueur maxi autorisée des chaines analysées
    Dim l1 As Long, l2 As Long, c1 As Long, c2 As Long
    Dim r() As Integer, rp() As Integer, rpp() As Integer, i As Integer, j As Integer
    Dim c As Integer, x As Integer, y As Integer, z As Integer, f1 As Integer, f2 As Integer
    Dim dls As Single, ac1() As Byte, ac2() As Byte
    l1 = Len(s1): l2 = Len(s2)
    If l1 > 0 And l1 <= cMaxLen And l2 > 0 And l2 <= cMaxLen Then
        ac1 = s1: ac2 = s2   'conversion des chaines en tableaux de bytes
        'Initialise la ligne précédente (rp) de la matrice
        ReDim rp(0 To l2)
        For i = 0 To l2: rp(i) = i: Next i
        For i = 1 To l1
            'Initialise la ligne courante de la matrice
            ReDim r(0 To l2): r(0) = i
            'Calcul le CharCode du caractère courant de la chaine
            f1 = (i - 1) * 2: c1 = ac1(f1 + 1) * cFacteur + ac1(f1)
            For j = 1 To l2
                f2 = (j - 1) * 2: c2 = ac2(f2 + 1) * cFacteur + ac2(f2)
                c = -(c1 <> c2)   'Cout : True = -1 => c = 1
                'suppression, insertion, substitution
                x = rp(j) + 1: y = r(j - 1) + 1: z = rp(j - 1) + c
                If x < y Then
                    If x < z Then r(j) = x Else r(j) = z
                Else
                    If y < z Then r(j) = y Else r(j) = z
                End If
                'transposition
                If i > 1 And j > 1 And c = 1 Then
                    If c1 = ac2(f2 - 1) * cFacteur + ac2(f2 - 2) And c2 = ac1(f1 - 1) * cFacteur + ac1(f1 - 2) Then
                        If r(j) > rpp(j - 2) + c Then r(j) = rpp(j - 2) + c
                    End If
                End If
            Next j
            'Reculer d'un niveau la ligne précédente (rp) et courante (r)
            rpp = rp: rp = r
        Next i
        'Calcul la similarité via la distance entre les chaines r(l2)
        If l1 >= l2 Then dls = 1 - r(l2) / l1 Else dls = 1 - r(l2) / l2
    ElseIf l1 > cMaxLen Or l2 > cMaxLen Then
        dls = -1   'indique un dépassement de longueur de chaine
    ElseIf l1 = 0 And l2 = 0 Then
        dls = 1   'cas particulier
    End If
 
    NOMSIMILAIRE = dls
End Function
Sub trillage()
    Dim compte As String, i As Long, col1 As String, col2 As String, col3 As String, liste() As Variant, _
        count As Long, fin As Long, cell As Range, nom As String, nombis As String, adresse1 As String, _
        adresse1bis As String, adresse2 As String, adresse2bis As String, e As Long, liste_a_effacer As String, a As Long
 
    compte = ""    'on vide la variable compte
 
    fin = Range("a" & Rows.count).End(xlUp).Row    'on determine la fin de la plage cellules a comparer
    i = 2    ' i est egale a la premiere ligne a comparer elle va nous servir un peu plus bas
    col1 = "d"    'les variable col representes les colonne a comparer
    col2 = "e"
    col3 = "f"
    For Each cell In Range("d2:d" & fin)    'on commence par boucler sur toute les cellule de la colonne "d" de la plage déterminée
        'avec les données des cellules en "d,e,f" on alimente les variable pour la boucle sur les "cell"
        nom = cell.Value: adresse1 = cell.Offset(0, 1).Value: adresse2 = cell.Offset(0, 2).Value
 
        For e = i + 1 To fin    ' maintenant on boucle sur la plage déterminé par la premiere boucle c'est a dire _
                                la premiere ligne est la suivante de la précedente boucle de facon a ne pas  faire 2 boucles entiere ce qui serait _
                                une perte de temps puisque la ligne 2 eme boucle est forcement passée dans la premiere
 
            'on alimente les variables avec les "cells"de la 2 eme boucle
            nombis = Cells(e, col1).Value: adresse1bis = Cells(e, col2).Value: adresse2bis = Cells(e, col3).Value
 
            'maintenant on compare l'indice de similarité des variable 1ere boucle et 2 eme boucle
            If NOMSIMILAIRE(UCase(nom), UCase(nombis)) > 0.9 And Cells(e, col2) <> "" And NOMSIMILAIRE(UCase(adresse1), UCase(adresse1bis)) > 0.85 _
               And NOMSIMILAIRE(UCase(adresse2), UCase(adresse2bis)) > 0.85 Then
                If InStr(compte, "*" & e & "*") > 0 Then    'si la ligne de la seconde boucle a deja été vu alors on fait rien
                Else
                    'sinon on aliment la variable count et on l'ajoute a la liste tu peux supprimer la ligne "liste_a_effacer" elle est la juste pour te montrer la liste
                    liste_a_effacer = liste_a_effacer & vbCrLf & "la ligne  " & Cells(e, col2).Row & "   " & nombis & "  est pareille que la ligne   " & cell.Row: count = count + 1
 
                    ReDim Preserve liste(count): liste(count) = Cells(e, col2).Row
                    compte = compte & "*" & e & "*"
                End If
            End If
        Next
        i = i + 1    'la variable s'incremente de 1 a chaque boucle cell ce qui te donne le debut de la plage pour la seconde recherche dans le 2 eme boucle
    Next
    Application.Speech.Speak "recherche   terrrmeenyy"    ' HA!!... CES ANGLAIS ILS ON UN BIEN DROLE ACCENTS
    MsgBox liste_a_effacer
    For a = 0 To count - 1
        '""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""
        'dans cette boucle tu peut effacer tout les doublons comme ceci:   il te suffit d'enlever l'apostrophe devant "cells"
        'Cells(liste(a), 1).EntireRow.Delete
        '"""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""
        Debug.Print liste(a)    ' si tu ouvre la fenetre d'execution tu pourra voir la liste des lignes a supprimer
    Next
End Sub

au plaisir