Recherche de mots clé dans une cellule

Function OccurrencesMots(Cel As Range) As String
Dim Texte As String, Liste, Liste2, i As Long, j As Long, Dico, Res() As String
    Liste = Array(",", ";", ".", "?", "!", "(", ")", "…", ":")
    Texte = LCase(Cel.Value)
    Texte = Replace(Texte, "'", " ")
    Texte = Replace(Texte, "’", " ")
    For i = LBound(Liste) To UBound(Liste)
        Texte = Replace(Texte, Liste(i), "")
    Next i
    Texte = Replace(Texte, Chr(10), " ")
    Texte = Application.Trim(Texte)
    Liste = Array("a", "à", "de", "du", "l", "d", "le", "la", "les", "des", "on", "c", "s", "qu", "que", "qui", "quoi", "donc", "si", "une", "un", "se", "sa", "ses", "son", "et", "ou")
        For i = LBound(Liste) To UBound(Liste)
    Texte = Replace(" " & Texte & " ", " " & Liste(i) & " ", " ")
    Next i
    ReDim Res(0)
    Texte = Application.Trim(Texte)
    Liste = Split(Texte)
    Set Dico = CreateObject("Scripting.Dictionary")
    For i = LBound(Liste) To UBound(Liste)
        If Dico.Exists(Liste(i)) Then
            Liste2 = Dico.keys
            j = Application.Match(Liste(i), Liste2, 0) - 1
            Res(j) = Res(j) + 1
        Else
            Dico(Liste(i)) = Liste(i)
            ReDim Preserve Res(Dico.Count - 1)
            Res(UBound(Res)) = 1
        End If
    Next i
    Liste2 = Dico.keys
    Texte = ""
    For i = LBound(Res) To UBound(Res)
    Texte = Texte & Liste2(i) & " : " & Res(i) & Chr(10)
    Next i
    OccurrencesMots = Texte
End Function

Function OccurrenceMot(Chaine As String, occurrence As Double) As String
Dim s As Variant, T(), T2(), TOc(), oRegExp As Object, Matches As Object
Dim I As Double, dico As Object, k As Byte
Chaine = Trim(LCase(Replace(Chaine, """", "")))
Set oRegExp = CreateObject("vbscript.regexp")
With oRegExp
  .Global = True
  .Pattern = "(?:[ \t\v\f]*([-,?!;.:…_–—()\[\]{}“”«»\\|/§~#`^@]+)[ \t\v\f]*)" ' '’
If .test(Chaine) = True Then Set Matches = .Execute(Chaine): Chaine = .Replace(Chaine, " ")
    
    'épurage des espaces en trop "
    .Pattern = "(\s){2,}"
    If .test(Chaine) = True Then Chaine = .Replace(Chaine, " ")
End With

Set dico = CreateObject("scripting.dictionary")
s = Split(Chaine)
For I = LBound(s) To UBound(s)
    dico(s(I)) = dico(s(I)) + 1
Next I
T = dico.keys
T2 = dico.items
ReDim TOc(1 To occurrence)
For I = 1 To occurrence
    k = Application.WorksheetFunction.Match(Application.WorksheetFunction.Large(T2, 1), T2, 0) - 1
    TOc(I) = T(k): T2(k) = ""
Next I
OccurrenceMot = Join(TOc, " ; ")
End Function

Function OccurrenceMot(Chaine As String, occurrence As Double) As String
Dim s As Variant, T(), T2(), TOc(), oRegExp As Object, Matches As Object
Dim i As Double, dico As Object, k As Byte, Borne As Byte
Chaine = Trim(LCase(Replace(Chaine, """", "")))
Set oRegExp = CreateObject("vbscript.regexp")
With oRegExp
  .Global = True
  .MultiLine = True
    'traitement des espaces
    .Pattern = "\s+"
    If .test(Chaine) = True Then Chaine = .Replace(Chaine, " ")
        
    'traitement des caractères ponctuation
    .Pattern = "[,?!;.:…_()\[\]{}“”«»\\|/§~#`^@]+" ' '’-–—
    If .test(Chaine) = True Then Chaine = .Replace(Chaine, " ")
      
    'traitement des apostrophes
    .Pattern = "(^|\s)(c|d|l|n|qu|s)(’|')"
    If .test(Chaine) = True Then Chaine = .Replace(Chaine, " ")
      
    'traitement des mots à 1 lettre
    .Pattern = "(^|\s)[àa](\s|$)"
    If .test(Chaine) = True Then Chaine = .Replace(Chaine, " ")
    
    'traitement des mots à 2 lettres
    .Pattern = "(^|\s)(au|e[nt]|n[ei]|o[nru]|[çclmnts][àaei]|d[eu]|un)(\b|$)"
    If .test(Chaine) = True Then Chaine = .Replace(Chaine, " ")
    
    'traitement des mots à 3 lettres
    .Pattern = "(^|\s)(aux|une|car|[dlmst]es|[mst](oi|on)|pas|qu[ei])(\b|$)"
    If .test(Chaine) = True Then Chaine = .Replace(Chaine, " ")
    
    'traitement des mots à 4 lettres
    .Pattern = "(^|\s)(donc|leur(s?)|mais|[n|v](o|ô)tre|plus|pour|tou[st]|trop)(\b|$)"
    If .test(Chaine) = True Then Chaine = .Replace(Chaine, " ")
    
    'traitement des mots à 5 lettres
    .Pattern = "(^|\s)(comme)(\b|$)"
    If .test(Chaine) = True Then Chaine = .Replace(Chaine, " ")
    
    'épurage des espaces en trop "
    .Pattern = "(\s){2,}"
    If .test(Chaine) = True Then Chaine = .Replace(Chaine, " ")
End With

Set dico = CreateObject("scripting.dictionary")
s = Split(Trim(Chaine))
For i = LBound(s) To UBound(s)
    dico(s(i)) = dico(s(i)) + 1
Next i
T = dico.keys
T2 = dico.items
Borne = Application.Min(dico.Count, occurrence)
ReDim TOc(1 To Borne)
For i = 1 To Borne
    k = Application.Match(Application.Max(T2), T2, 0) - 1
    TOc(i) = T(k) & " (" & T2(k) & ")": T2(k) = ""
Next i
OccurrenceMot = Join(TOc, vbLf)
End Function