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 |
Partager