Discussion :

[marcelisa2]

Bonjour,
Je suis à la recherche d'un exemple de programme, fonction qui me permette de détecter dans une liste de nom de personne, des possibles doublons et qu'il me soit proposé via un formulaire.

J'ai une table TF_Personne contenant les champs suivants

J'ai ma table de chargement des données qui a la même structure que celle présentée précédemment

A ce jour, je ne fais que comparer le contenu des 3 champs strictement, mais malheureusement cela ne permet pas d'avoir la réelle exhaustivité sur les doublons de la Base.

Ainsi, par exemple, si le nom de la personne dans la Base s’écrit : dupoït et dans la table de chargement nous avons dupoit, le doublon ne sera pas détecté (différence au niveau de la lettre i).
Le sujet est identique pour tous les problèmes d'accent ou éventuellement des différences sur des particules, etc... ou une lettre différente dans un mot ( ex: dupont et dupent )

L'idée serait de lire le nom ( éventuellement avec le prénom ) et de le comparer, avec la liste des noms de la table TF_personne, lettre par lettre et en fonction d'un taux important de correspondance, de l'afficher à l'utilisateur pour qu'il valide qu'il s'agit bien d'un doublon ou nom

En vous remerciant par avance pour votre aide.

Bien cordialement

[loufab]

Bonjour,

Si ce n'est qu'un problème d'accent :

https://www.developpez.net/forums/d1...ompte-accents/

Cordialement,

[marcelisa2]

Bonjour Loufab,
Merci beaucoup pour l'exemple sur la gestion des accents. Je traite maintenant cet aspect.

Maintenant je me retrouve dans un autre cas.
Soit par exemple :
1) dans ma table TF_Personne (Table principale de ma Base access), j'ai un nom du type "dupont de durand".
2) Lors du chargement des noms de nouvelles personnes dans la table temporaire ( TT_personne chargement), j'ai un nom du type "dupont".
3) Je cherche un moyen de faire apparaitre dans un écran d'affichage le nom "dupont de durand" car il ressemble à 50% à celui de la table temporaire "dupont".
4) L'utilisateur devra valider s'il considère que c'est un doublon ou non ( donc mal orthographié dans la table temporaire ) => cette personne "dupont de durand" sera donc sauvegardé avec la personne"dupont" dans la table finale TT_doublon_personne

Avez-vous une idée de traitement pour améliorer mon code ci-dessous?
Merci par avance pour votre aide

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
105
106
107
 
Private Sub recherche_doublon_Click()
On Error GoTo Err_btdoublonpersonne_Click
 
    Dim stDocName As String
 
    ' vidage de la table temporaire de validation des personnes
    stDocName = "R_supp_TT_personne_doublon"
    DoCmd.OpenQuery stDocName, acNormal, acEdit
 
    'recherche des doublons
    Dim strSQL As String
    Dim rct As DAO.Recordset 'record table travail de chargement
    Dim rcv As DAO.Recordset 'record version originale TF_personne
    Dim rcs As DAO.Recordset 'record table sortie
    Dim rcc As DAO.Recordset 'record composition contact
 
    Dim v_nom_personne, v_prenom_personne, v_prenom_personne_orig, v_nom_personne_orig As String
    Dim v_nbr_lettre As Integer
    Dim v_num_contact As Integer
 
   '------------ selection de tous les enregistrements personne -------------------------------
        strSQL = "SELECT * FROM TT_personne_chargement"
 
      '-------------------------------------------------------------------
 
        Set rct = CurrentDb.OpenRecordset(strSQL, DB_OPEN_DYNASET)
        While rct.EOF = False
         rct.Edit
         'lecture nom personne et transformation des lettres avec accent
         v_prenom_personne = sansAccent(rct.Fields(2), False)
         v_nom_personne = sansAccent(rct.Fields(3), False)
         v_nbr_lettre = Len(v_nom_personne)
 
           '------------ selection de tous les enregistrements personne -------------------------------
           strSQL = "SELECT * FROM TF_personne"
 
           Set rcv = CurrentDb.OpenRecordset(strSQL, DB_OPEN_DYNASET)
 
           While rcv.EOF = False
            rcv.Edit
 
             v_prenom_personne_orig = sansAccent(rcv.Fields(2), False)
             v_nom_personne_orig = sansAccent(rcv.Fields(3), False)
 
             If v_nom_personne_orig = v_nom_personne Then
               If v_prenom_personne_orig = v_prenom_personne Then
               ' MsgBox "Nom origine identique à celui chargé :" & v_nom_personne & " trouvé :" & rcv.Fields(0) & " " & v_prenom_personne_orig & " " & v_nom_personne_orig
 
                'recherche de la composition du contact
                strSQL = "SELECT * FROM [TF_composition contact]"
 
                Set rcc = CurrentDb.OpenRecordset(strSQL, DB_OPEN_DYNASET)
 
                While rcc.EOF = False
                  rcc.Edit
                  If rcv.Fields(0) = rcc.Fields(1) Then
                    v_num_contact = rcc.Fields(0)
                  End If
                  rcc.MoveNext
                Wend
 
                'table sortie TT_personne_doublon
 
                '*N° personne TF : N° personne table TF_personne
                '*N° contact :  N° contact table TF_composition_contact
                '*Titre personne : Titre personne table TF_personne
                '*prénom personne: prénom personne table TF_personne
                '*Nom personne: Nom personne table TF_personne
                '*n° personne TT : N° personne table TT_personne_chargement
 
                 strSQL = "SELECT * FROM TT_personne_doublon"
 
                 Set rcs = CurrentDb.OpenRecordset(strSQL, DB_OPEN_DYNASET)
 
                    rcs.AddNew
 
                    rcs![N° personne TF] = rcv.Fields(0)
                    rcs![N° contact] = v_num_contact
                    rcs![Titre personne] = rcv.Fields(1)
                    rcs![prénom personne] = v_prenom_personne_orig
                    rcs![Nom personne] = v_nom_personne_orig
                    rcs![n° personne TT] = rct.Fields(0)
 
                    rcs.Update
                 End If
               End If
 
            rcv.MoveNext
 
           Wend
 
           rcv.Close
 
       '  rct.Update
         rct.MoveNext
        Wend
 
        rct.Close 
 
 
Exit_btdoublonpersonne_Click:
    Exit Sub
 
Err_btdoublonpersonne_Click:
    MsgBox Err.Description
    Resume Exit_btdoublonpersonne_Click

[Invité]

Bonjour

Je te conseil d'utiliser un algorithme style Levenstein.

En utilisant la fonction qui est dans ce lien avec un ration de 0.61 cela devrait donner de bons résultats.

https://blog.developpez.com/philben/...nes_de_caracte

Je l'utilise dans un de mes programmes et cela marche du tonnerre, même si le traitement est un peu allongé.

Philippe

[marcelisa2]

super Philippe !
je vais essayer de regarder les algorithmes pour essayer de les adapter à mon cas.

[Invité]

Bonjour

Tu peux mettre la fonction telle quelle dans un module en la déclaration en public et l'utiliser dans une requête.

Tu passes dans cette fonction les deux données à tester et tu régardes le résultat, si c'est supérieur à 0.61 tu demandes un contrôle.

Je l'utilises pour contrôles des fichiers d'adresses.

Philippe

[marcelisa2]

Hello,

Je viens d'essayer. J'ai créé des zones de %tage pour l'analyse sur le nom et le prénom

Je constate que, pour arriver à faire ressortir mon cas particulier de l'exemple précédent de la base principale "dupont de durand" par rapport à la saisie "dupont", il me faut descendre le pourcentage sur le nom à 0.31.
Je demande que les prénoms soient identiques à 0.96 près.

Peut être que je me trompe dans mon code

une meilleure idée?

voici le code

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
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
 
Private Sub recherche_doublon_Click()
On Error GoTo Err_btdoublonpersonne_Click
 
    Dim stDocName As String
 
    ' vidage de la table temporaire de validation des personnes
    stDocName = "R_supp_TT_validation_personne"
    DoCmd.OpenQuery stDocName, acNormal, acEdit
 
    ' vidage de la table temporaire de validation des personnes
    stDocName = "R_supp_TT_personne_doublon"
    DoCmd.OpenQuery stDocName, acNormal, acEdit
 
    'recherche des doublons
    Dim strSQL As String
    Dim rct As DAO.Recordset 'record table travail de chargement
    Dim rcv As DAO.Recordset 'record version originale TF_personne
    Dim rcs As DAO.Recordset 'record table sortie
    Dim rcc As DAO.Recordset 'record composition contact
    Dim nbenr As Integer 'nbre enregistrement table TT_personne_chargement
 
   '---------affichage de la barre de progression -------------------------------
   Dim lCptIteration1 As Long
   Dim lCptIteration2 As Long
   Dim lString As String
    Dim lPercent As Single
   Const lNbIterations As Long = 10000
   ' Ouverture du formulaire d'attente
   DoCmd.OpenForm "F_FormAttente"
   Forms("F_FormAttente").lblInfo.Caption = "Veuillez patienter durant le traitement de recherche doublon... "
   Forms("F_FormAttente").lblProgressBar.Width = 0
   ' Nécessaire pour redonner la main à windows le temps de traiter les messages dans la pile
   DoEvents
 
   '---------------------------------------
    Dim v_nom_personne, v_prenom_personne, v_prenom_personne_orig, v_nom_personne_orig As String
    Dim v_nbr_lettre As Integer
    Dim v_num_contact As Integer
 
   '------------ selection de tous les enregistrements personne -------------------------------
        strSQL = "SELECT * FROM TT_personne_chargement"
 
        '---------- vérification si + d'un blanc entre nom et prénom ---------------------
 
        Set rct = CurrentDb.OpenRecordset(strSQL, DB_OPEN_DYNASET)
 
        nbenr = DCount("[n° personne]", "TT_personne_chargement")
 
        lCptIteration1 = 1
 
        While rct.EOF = False
         rct.Edit
         'lecture nom personne et transformation des lettres avec accent
 
         v_prenom_personne = sansAccent(rct.Fields(2), False)
         v_nom_personne = sansAccent(rct.Fields(3), False)
         v_nbr_lettre = Len(v_nom_personne)
 
         '------------ selection de tous les enregistrements personne -------------------------------
           strSQL = "SELECT * FROM TF_personne ORDER BY TF_personne.[Nom personne] ASC"
 
           Set rcv = CurrentDb.OpenRecordset(strSQL, DB_OPEN_DYNASET)
 
           While rcv.EOF = False
            rcv.Edit
 
             v_prenom_personne_orig = sansAccent(rcv.Fields(2), False)
             v_nom_personne_orig = sansAccent(rcv.Fields(3), False)
 
             If DamerauLevenshteinSimilarite(v_nom_personne_orig, v_nom_personne) > Val(Me.pctagenom.Value) Then
               If DamerauLevenshteinSimilarite(v_prenom_personne_orig, v_prenom_personne) > Val(Me.pctageprenom.Value) Then
               ' MsgBox "Nom origine identique à celui chargé :" & v_nom_personne & " trouvé :" & rcv.Fields(0) & " " & v_prenom_personne_orig & " " & v_nom_personne_orig
 
                'recherche de la composition du contact
                strSQL = "SELECT * FROM [TF_composition contact]"
 
                Set rcc = CurrentDb.OpenRecordset(strSQL, DB_OPEN_DYNASET)
 
                While rcc.EOF = False
                  rcc.Edit
                  If rcv.Fields(0) = rcc.Fields(1) Then
                    v_num_contact = rcc.Fields(0)
                  End If
                  rcc.MoveNext
                Wend
 
                'table sortie TT_personne_doublon
 
                '*N° personne TF : N° personne table TF_personne
                '*N° contact :  N° contact table TF_composition_contact
                '*Titre personne : Titre personne table TF_personne
                '*prénom personne: prénom personne table TF_personne
                '*Nom personne: Nom personne table TF_personne
                '*n° personne TT : N° personne table TT_personne_chargement
 
                 strSQL = "SELECT * FROM TT_personne_doublon"
 
                 Set rcs = CurrentDb.OpenRecordset(strSQL, DB_OPEN_DYNASET)
 
                    rcs.AddNew
 
                    rcs![N° personne TF] = rcv.Fields(0)
                    rcs![n° contact] = v_num_contact
                    rcs![titre personne] = rcv.Fields(1)
                    rcs![prénom personne] = v_prenom_personne_orig
                    rcs![Nom personne] = v_nom_personne_orig
                    rcs![n° personne TT] = rct.Fields(0)
 
                    rcs.Update
 
                 End If
               End If
 
            rcv.MoveNext
 
           Wend
 
           rcv.Close
 
       '  rct.Update
 
       '----------- augmentation barre progression à chaque lecture de personne
            ' Calcul du pourcentage d'avancement
            lPercent = lCptIteration1 / nbenr
            ' Met à jour l'étiquette d'avancement
            Forms("F_FormAttente").lblProgress.Caption = "Traitement en cours ... " & Format(lPercent, "00%")
            ' Met à jour la barre de progression
            Forms("F_FormAttente").lblProgressBar.Width = Forms("F_FormAttente").lblProgressBack.Width * lPercent
            ' Repeint le formulaire
            Forms("F_FormAttente").Repaint
            ' Evite que l'application ne soit figée
            DoEvents
 
            lCptIteration1 = lCptIteration1 + 1
       '-----------------------------------------------------------------------------
         rct.MoveNext
        Wend
 
        rct.Close
 
 
 
 
' Fermeture du formulaire d'attente
DoCmd.Close acForm, "F_FormAttente"
 
rcs.Close
 
    'Recherche de doublons avec la table personne
    stDocName = "Rq_personne_doublon_m"
    DoCmd.OpenQuery stDocName, acNormal, acEdit
 
 
Exit_btdoublonpersonne_Click:
    Exit Sub
 
Err_btdoublonpersonne_Click:
    MsgBox "Erreur lors du traitement, n° " & Err.Number & ", " & Err.Description, vbOKOnly
    DoCmd.Close acForm, "F_FormAttente"
    Resume Exit_btdoublonpersonne_Click
End Sub
Public Function sansAccent(ByVal Chaine As String, EnMajuscule As Boolean) As String
Chaine = LCase(Chaine)
Chaine = Replace(Chaine, Chr(232), "e")
Chaine = Replace(Chaine, Chr(233), "e")
Chaine = Replace(Chaine, Chr(234), "e")
Chaine = Replace(Chaine, Chr(235), "e")
Chaine = Replace(Chaine, Chr(249), "u")
Chaine = Replace(Chaine, Chr(250), "u")
Chaine = Replace(Chaine, Chr(251), "u")
Chaine = Replace(Chaine, Chr(242), "o")
Chaine = Replace(Chaine, Chr(244), "o")
Chaine = Replace(Chaine, Chr(254), "o")
Chaine = Replace(Chaine, Chr(255), "y")
Chaine = Replace(Chaine, Chr(224), "a")
Chaine = Replace(Chaine, Chr(225), "a")
Chaine = Replace(Chaine, Chr(226), "a")
Chaine = Replace(Chaine, Chr(238), "i")
Chaine = Replace(Chaine, Chr(239), "i")
Chaine = Replace(Chaine, Chr(244), "o")
If EnMajuscule Then Chaine = UCase(Chaine)
sansAccent = Chaine
End Function
 
Public Function DamerauLevenshteinSimilarite(ByVal s1 As String, ByVal s2 As String) As Single
 
  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
 
   DamerauLevenshteinSimilarite = dls
End Function

[marcelisa2]

Bonsoir,
en final je pense que j'arrive à détecter à peu près tous les doublons avec l'algorithme.
Merci encore à tous pour votre aide.

cdlt