Recherche d'une chaine de caractères sans tenir compte de l'ordre des mots dans les chaines de caractères

Télécharger le projet
Commenter

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.

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)
Télécharger le projet

Codes Sources

A voir également

S'inscrire maintenant

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.

Du même auteur (cs_8Tnerolf8)