Soyez le premier à donner votre avis sur cette source.
Vue 7 250 fois - Téléchargée 637 fois
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
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.