patricktoulon
XLDnaute Barbatruc
Bonjour à tous et @Dudu2
j'ouvre cette discussion a fin de ne pas mettre le boxon dans une autre dans la quelle j'ai proposer la fonction similaire
en 2020/2021 je sais plus trop j'avais ajouté dans la fonction une partie gérant la présence de chaque mot de la chaine 1 dans la chaine 2
cela dit je me rend compte qu'elle peut être discriminatoire ou inversement me donner un 100%
alors que la chaine 2 est plus grande
certes la chaine2 contient tout les mots de la chaine 1 mais le pourcentage ne devrait pas être 100%
voici la fonction je n'en suis pas l'auteur à la base je l'ai juste arrangée a ma sauce
prenons un exemple de chaines à comparer
maintenant si je met un pluriel
je cherche le moyen donc de garder la partie unordered mais quelle soit plus juste
j'ai donc dans un fichier vierge cherché un moyen que cette partie soit plus juste au résultat
j'ai donc écrit ce nouveau code pour tester
en fait j'ai un 100% si tout les mots sont présents dans n'importe quel ordre
et j'impute une devaluation en fonction du nombre de mots supplémentaires
dites moi ce que vous en pensez
pensez vous que ce soit rentable de l'intégrer dans la fonction similaire dans a la place de la partie unordered
avec peut être un switch ressemblance/similaire
Allez @Dudu2 au boulot
je joins un fichier
j'ouvre cette discussion a fin de ne pas mettre le boxon dans une autre dans la quelle j'ai proposer la fonction similaire
en 2020/2021 je sais plus trop j'avais ajouté dans la fonction une partie gérant la présence de chaque mot de la chaine 1 dans la chaine 2
cela dit je me rend compte qu'elle peut être discriminatoire ou inversement me donner un 100%
alors que la chaine 2 est plus grande
certes la chaine2 contient tout les mots de la chaine 1 mais le pourcentage ne devrait pas être 100%
voici la fonction je n'en suis pas l'auteur à la base je l'ai juste arrangée a ma sauce
VB:
Public Function similaire(ByVal s1 As String, ByVal s2 As String) As Double
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 String, ac1() As Byte, ac2() As Byte
Dim px As Double, p As Double, oz As Long
Dim t1, t2
'*****************************************************
'analyse dans un ordre different
If s1 = s2 Then similaire = 100: Exit Function
t1 = Split(Replace(s1, "-", " "), " "): t2 = Split(Replace(s1, "-", " "), " ")
If UBound(t2) > UBound(t1) Then tbl = t12: s2 = s1 Else tbl = t1
If IsArray(tbl) Then
If UBound(tbl) > 1 Then
p = 100 / (UBound(tbl) + 1)
For oz = 0 To UBound(tbl): px = px + IIf(" " & s2 & " " Like "* " & tbl(oz) & "* ", p, -p): Next
If px = 100 Then similaire = 100: Exit Function
End If
End If
'**************************************************
'analyse binaire
l1 = Len(s1): l2 = Len(s2)
If l1 > 0 And l1 <= cMaxLen And l2 > 0 And l2 <= cMaxLen Then
ac1 = s1 'conversion des chaines en tableaux de bytes
ac2 = s2
'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
similaire = dls * 100
End Functionprenons un exemple de chaines à comparer
maintenant si je met un pluriel
alors oui tout les mots de la chaine 1 se trouvent dans la chaine 2 mais elle ne sont pas egales
je cherche le moyen donc de garder la partie unordered mais quelle soit plus juste
j'ai donc dans un fichier vierge cherché un moyen que cette partie soit plus juste au résultat
j'ai donc écrit ce nouveau code pour tester
VB:
Function Ressemble(s1 As String, s2 As String)
Dim T2, T1, TbL, x, px#, devaluation#
s1 = Trim(s1): s2 = Trim(s2)
s1 = Replace(s1, "-", " ")
s2 = Replace(s2, "-", " ")
'*****************************************************
'analyse dans un ordre different(UNORDERED)
If s1 = s2 Then Ressemble = 100: Exit Function
T1 = Split(s1, " ")
T2 = Split(s2, " ")
x = WorksheetFunction.Max(UBound(T1), UBound(T2))
y = WorksheetFunction.Min(UBound(T1), UBound(T2))
devaluation = ((100 / x) * Abs(x - y)) / 2
If UBound(T2) < UBound(T1) Then TbL = T2: s2 = s1 Else TbL = T1
If IsArray(TbL) Then
If UBound(TbL) > 1 Then
p = 100 / (UBound(T1) + 1)
For oz = 0 To UBound(TbL)
If " " & s2 & " " Like "* " & TbL(oz) & " *" Then px = px + p
Next
End If
End If
'pour rendre la note equitable par rapport au nombre de mots supplémentaire
If Val(px) = 100 Then px = px - devaluation
Ressemble = px
End Function
MsgBox Ressemble("les pommes du pays de galle", "les pommes du pays de galle")
MsgBox Ressemble("les pommes du pays de galle", "les pommes vertes du pays de galle")et j'impute une devaluation en fonction du nombre de mots supplémentaires
dites moi ce que vous en pensez
pensez vous que ce soit rentable de l'intégrer dans la fonction similaire dans a la place de la partie unordered
avec peut être un switch ressemblance/similaire
Allez @Dudu2 au boulot
je joins un fichier
