Recherche d'une chaine de caractères sans tenir compte de l'ordre des mots dans les chaines de caractères
Soyez le premier à donner votre avis sur cette source.
Vue 6 798 fois - Téléchargée 618 fois
Description
Dans le cadre de ma mission actuelle, j'ai été confronté à la problématique consistant à faire correspondre l'identité de personnes dans deux colonnes d'un classeur, sachant que la nomenclature de ces valeurs était différente entre les deux colonnes.
C'est pour cela que j'ai développé une fonction permettant de faire des rapprochements entre les mots d'une chaine de caractères, sans tenir compte de leur casse, accentuation et disposition.
Pré requis :
La bibliothèque Microsoft "VBScript Regular Expressions 5.5"
Library VBScript_RegExp_55 dans [Chemin vers Windows]\[System32 ou SysWOW64]\vbscript.dll\3
- La fonction "Desaccentue" remplace tous les caractères accentués présents dans une chaine de caractères par leur homologue sans accents.
- La fonction "MatchEnDesordre" permet de trouver tous les mots dans une zone de recherche, quelque soit l'ordre de ces derniers, leur casse ou leur accentuation.
Vous trouverez dans la copie d'écran et dans le zip un exemple d'utilisation dans une feuille Excel.
Au niveau VBA cela donne :
'Recherche sur chaine de caractères :
Trouve = MatchEnDesordre("Once Upon a Time", "UpöN TImE à")
'Avec VBA Excel :
'Recherche avec Concordance stricte
Trouve = MatchEnDesordre("Once Upon a Time", Range("$G:$G"), StricteConcordance:=True)
'Recherche avec Concordance partielle
Trouve = MatchEnDesordre(Range("A1"), Range("$G:$G"), StricteConcordance:=False)
'Recherche en ajoutant le "." comme caractère d'explosion
Trouve = MatchEnDesordre("Once Upon a Time", Range("$G:$G"), Explosion:="\s,;:\._\|\\-")
'Recherche avec un enregistrement DAO ou ADO :
Set Rs = CurrentDB.OpenRecordset("SELECT * FROM MaTable", DbOpenSnapShot)
Trouve = MatchEnDesordre("Once Upon a Time", Rs)
C'est pour cela que j'ai développé une fonction permettant de faire des rapprochements entre les mots d'une chaine de caractères, sans tenir compte de leur casse, accentuation et disposition.
Pré requis :
La bibliothèque Microsoft "VBScript Regular Expressions 5.5"
Library VBScript_RegExp_55 dans [Chemin vers Windows]\[System32 ou SysWOW64]\vbscript.dll\3
- La fonction "Desaccentue" remplace tous les caractères accentués présents dans une chaine de caractères par leur homologue sans accents.
- La fonction "MatchEnDesordre" permet de trouver tous les mots dans une zone de recherche, quelque soit l'ordre de ces derniers, leur casse ou leur accentuation.
Source / Exemple :
Option Explicit
Public Function MatchEnDesordre(ByVal Val_Recherche As String, ByVal ZoneRecherche As Variant, Optional Explosion As String = "\s,;:_\|\\-", _
Optional StricteConcordance As Boolean = True, Optional Reinit As Boolean = True) As String
'Cette fonction , après avoir désaccentué Val_Recherche et ZoneRecherche, explose ces valeurs par les caractères présents dans Explosion
'Elle compare ensuite le nombre de correspondances trouvées avec ZoneRecherche.
'- Si StricteConcordonnance est Vrai et que le nombre de résultats de ZoneRecherche est égal à celui de Val_Recherche,
'alors la valeur renvoyée est celle de ZoneRecherche
'- Si StricteConcordonnance est Faux et que le nombre de résultats de ZoneRecherche est inférieur ou égal à celui de Val_Recherche,
'alors la valeur renvoyée est celle de ZoneRecherche
'- Si ZoneRecherche est une plage, alors la fonction est appelée de manière récursive sur chaque cellule de cette plage
'- Si ZoneRecherche est un enregistrement DAO ou ADO, alors la fonction est appelée de manière récursive sur chaque ligne de l'enregistrement
'Elle retourne la première correspondance trouvée
'Pré requis :
'La bibliothèque Microsoft "VBScript Regular Expressions 5.5"
'Library VBScript_RegExp_55 dans [Chemin vers Windows]\[System32 ou SysWOW64]\vbscript.dll\3
Dim Regle As New RegExp, Results As MatchCollection, SsResult As Match, Cellule As Variant, MotifRechercheCorrespondances As String
Dim NbreParties(1) As Integer, SaveCasse As Variant, DerniereLigne As Long, Tampon As Variant
Static Trouve As Boolean
If Reinit Then Trouve = False
If TypeName(ZoneRecherche) = "Range" Then
'On détermine quelle est la dernière ligne utilisée dans la feuille
DerniereLigne = ZoneRecherche.Parent.UsedRange.Cells(ZoneRecherche.Parent.UsedRange.Cells.Count).Row
For Each Cellule In ZoneRecherche.Cells
If Cellule.Row > DerniereLigne Then Exit For 'Cela permet de ne pas parcourir 65 536 lignes ou plus lorsque l'on
'choisit une colonne
Tampon = Cellule
Tampon = MatchEnDesordre(Val_Recherche, Tampon, Explosion, StricteConcordance, False)
If Trouve Then
MatchEnDesordre = Tampon
Exit Function
End If
DoEvents
Next Cellule
Exit Function
ElseIf TypeName(ZoneRecherche) = "Recordset" Or TypeName(ZoneRecherche) = "Recordset2" Then
With ZoneRecherche
If .RecordCount = 0 Then Exit Function
.MoveFirst
Do Until .EOF
If Not IsNull(.Fields(0)) Then Tampon = MatchEnDesordre(Val_Recherche, .Fields(0), Explosion, StricteConcordance, False)
If Trouve Then
MatchEnDesordre = Tampon
Exit Function
End If
.MoveNext
DoEvents
Loop
End With
End If
SaveCasse = ZoneRecherche
Val_Recherche = Desaccentue(Val_Recherche, Transfo_caract:=1): ZoneRecherche = Desaccentue(CStr(ZoneRecherche), Transfo_caract:=1)
'On explose Val_Recherche par le motif contenu dans Explosion
With Regle
.Global = True
.IgnoreCase = True
.Pattern = "([^" & Explosion & "]+)"
Set Results = .Execute(Val_Recherche)
End With
If Results.Count = 0 Then Exit Function
NbreParties(0) = Results.Count
'On construit le motif qui servira à voir les correspondances dans ZoneRecherche
For Each SsResult In Results
MotifRechercheCorrespondances = MotifRechercheCorrespondances & SsResult & "|"
Next SsResult
'On enlève le dernier "|"
MotifRechercheCorrespondances = Left(MotifRechercheCorrespondances, Len(MotifRechercheCorrespondances) - 1)
MotifRechercheCorrespondances = "(?:" & MotifRechercheCorrespondances & ")"
With Regle
.Pattern = MotifRechercheCorrespondances
Set Results = .Execute(ZoneRecherche)
End With
If Results.Count = 0 Then Exit Function
NbreParties(1) = Results.Count
If Not StricteConcordance Then
Trouve = (NbreParties(0) = NbreParties(1))
'Exemple d'explication
'Val_Recherche = "FLORENT BENETIERE" : ZoneRecherche = "BENETIERE FLORENT TOTO"
'ZoneRecherche contiendra FLORENT et BENETIERE
'=>NbreParties(0) = NbreParties(1) = 2 = 2
'NbreParties(0) =[FLORENT][BENETIERE] | NbreParties(1)=[BENETIERE][FLORENT]
'Comme la concordance n'est pas stricte, on ne tient pas compte qu'il y ait TOTO en plus dans ZoneRecherche
Else
'On supprime de ZoneRecherche les occurrences trouvées
'Si après suppression ZoneRecherche est vide, c'est que les chaines de caractères sont identiques
'dans Val_Recherche et ZoneRecherche, même si elles ne sont pas dans le même ordre
With Regle
ZoneRecherche = .Replace(ZoneRecherche, vbNullString)
.Pattern = "[" & Explosion & "]+"
ZoneRecherche = .Replace(ZoneRecherche, vbNullString)
End With
Trouve = (ZoneRecherche = vbNullString)
End If
If Trouve Then MatchEnDesordre = SaveCasse
End Function
Public Function Desaccentue(Chaine As String, Optional Transfo_suppl_source As String = "_", _
Optional Transfo_suppl_cible As String = " ", Optional Transfo_caract As Byte = 0) As String
'Cette fonction remplace tous les caractères accentués présent dans Chaine par leur homologue sans accents
'- Transfo_suppl_source ajoute une chaîne de caractères à remplacer par Transfo_suppl_cible
'- Transfo_caract permet de convertir éventuellement les lettres en capitales (Transfo_caract=1) ou en minuscules (Transfo_caract=2)
Dim Regle As New RegExp
Chaine = Trim(Chaine)
With Regle
.IgnoreCase = False
.Global = True
.Pattern = "[ÀÁÂÃÄÅÆ]"
Chaine = .Replace(Chaine, "A")
.Pattern = "[àáâãäåæ]"
Chaine = .Replace(Chaine, "a")
.Pattern = "[ß]"
Chaine = .Replace(Chaine, "B")
.Pattern = "[Ç]"
Chaine = .Replace(Chaine, "C")
.Pattern = "[ç]"
Chaine = .Replace(Chaine, "c")
.Pattern = "[Ð]"
Chaine = .Replace(Chaine, "D")
.Pattern = "[ÈÉÊË]"
Chaine = .Replace(Chaine, "E")
.Pattern = "[èéêë]"
Chaine = .Replace(Chaine, "e")
.Pattern = "[ÌÍÎÏ]"
Chaine = .Replace(Chaine, "I")
.Pattern = "[ìíîï]"
Chaine = .Replace(Chaine, "i")
.Pattern = "[Ñ]"
Chaine = .Replace(Chaine, "N")
.Pattern = "[ñ]"
Chaine = .Replace(Chaine, "n")
.Pattern = "[ÒÓÔÕÖØ]"
Chaine = .Replace(Chaine, "O")
.Pattern = "[ðòóôõöø]"
Chaine = .Replace(Chaine, "o")
.Pattern = "[þ]"
Chaine = .Replace(Chaine, "P")
.Pattern = "[Þ]"
Chaine = .Replace(Chaine, "p")
.Pattern = "[]"
Chaine = .Replace(Chaine, "S")
.Pattern = "[]"
Chaine = .Replace(Chaine, "s")
.Pattern = "[ÙÚÛÜ]"
Chaine = .Replace(Chaine, "U")
.Pattern = "[ùúûü]"
Chaine = .Replace(Chaine, "u")
.Pattern = "[×]"
Chaine = .Replace(Chaine, "x")
.Pattern = "[Ý]"
Chaine = .Replace(Chaine, "Y")
.Pattern = "[ýÿ]"
Chaine = .Replace(Chaine, "y")
.Pattern = "[]"
Chaine = .Replace(Chaine, "Z")
.Pattern = "[]"
Chaine = .Replace(Chaine, "z")
End With
If Transfo_suppl_source <> vbNullString Then
Chaine = Replace(Chaine, Transfo_suppl_source, Transfo_suppl_cible, , , vbBinaryCompare)
End If
If Transfo_caract > 0 Then Chaine = IIf(Transfo_caract = 1, UCase(Chaine), LCase(Chaine))
Desaccentue = Chaine
End Function
Conclusion :
Vous trouverez dans la copie d'écran et dans le zip un exemple d'utilisation dans une feuille Excel.
Au niveau VBA cela donne :
'Recherche sur chaine de caractères :
Trouve = MatchEnDesordre("Once Upon a Time", "UpöN TImE à")
'Avec VBA Excel :
'Recherche avec Concordance stricte
Trouve = MatchEnDesordre("Once Upon a Time", Range("$G:$G"), StricteConcordance:=True)
'Recherche avec Concordance partielle
Trouve = MatchEnDesordre(Range("A1"), Range("$G:$G"), StricteConcordance:=False)
'Recherche en ajoutant le "." comme caractère d'explosion
Trouve = MatchEnDesordre("Once Upon a Time", Range("$G:$G"), Explosion:="\s,;:\._\|\\-")
'Recherche avec un enregistrement DAO ou ADO :
Set Rs = CurrentDB.OpenRecordset("SELECT * FROM MaTable", DbOpenSnapShot)
Trouve = MatchEnDesordre("Once Upon a Time", Rs)
Codes Sources
A voir également
- Recherche d'une chaine de caractères sans tenir compte de l'ordre des mots dans les chaines de caractères
- Recherche sans tenir compte des accents ✓ - Forum - SQL
- Effectuer une recherche sans tenir compte des majuscules/minuscules ✓ - Forum - SQL
- Javascript : Ajax inter-site (cross-site) sous ie sans tenir compte des paramètres de s&eacut - Guide
- Comparaison de strings sans tenir compte des accents ✓ - Forum - Delphi / Pascal
- Remplacer une chaine de caractere sans tenir comtpe de la case ✓ - Forum - VB.NET
Vous n'êtes pas encore membre ?
inscrivez-vous, c'est gratuit et ça prend moins d'une minute !
Les membres obtiennent plus de réponses que les utilisateurs anonymes.
Le fait d'être membre vous permet d'avoir un suivi détaillé de vos demandes et codes sources.
Le fait d'être membre vous permet d'avoir des options supplémentaires.