XL 2019 Recherche mots dans cellule et résultat dans cellule avec séparateur

Sub Traitement()

'déclaration de deux tablo +  1 dico
Dim TabData() As Variant
Dim TabCat() As Variant
Dim Dico As Object

Set Dico = CreateObject("scripting.dictionary") 'création du dico

With Sheets("Product") 'dans la feuille "Product"
    LastLine = .UsedRange.Rows.Count 'dernière ligne utilisée de la feuille
    TabData = .Range("F2:F" & LastLine).Value 'on met la colonne F dans le tablo
End With

With Sheets("Dico") 'dans la feuille "Dico"
    LastLine = .UsedRange.Rows.Count 'dernière ligne utilisée de la feuille
    TabCat = .Range("A2:A" & LastLine).Value 'on met les colonnes A à A dans le tablo
End With

'Remplissage du dico
For i = LBound(TabCat, 1) To UBound(TabCat, 1) 'pour chaque ligne du tablo
    IdCat = TabCat(i, 1) 'on récupère l'ID
   
    If Not Dico.exists(IdCat) Then 'si l'ID n'est pas dans le dico
        Dico.Add IdCat, i 'on l'ajoute
    End If
Next i

'recherche des mots clés
For i = LBound(TabData, 1) To UBound(TabData, 1) 'pour chaque ligne du tablo
chaine = ""

    For Each ele In Dico.keys ' pour chaque élément = pour chaque ID
        If InStr(1, TabData(i, 1), ele) <> 0 Then
            chaine = chaine & Chr(10) & ele 'on remplace l'ID par son nom trouvé dans le dictionnaire
        End If
       
    Next ele
    TabData(i, 1) = chaine 'on reforme la liste complète avec le ; en séparateur
Next i

Sheets("Product").Range("U2").Resize(UBound(TabData, 1)) = TabData 'on colle le résultat en colonne T
End Sub

=JOINDRE.TEXTE("|";VRAI;SI(ESTERREUR(CHERCHE(" " & dicoCAT & " ";" " & SUBSTITUE(SUBSTITUE(F2;",";" ");".";" ") & " "));"";dicoCAT))

=SIERREUR(GAUCHE(CONCAT(SI(SI(ESTNUM(EQUIV("*"&Dico!$A$2:$A$16&"*";product!F2;0))=VRAI;Dico!$A$2:$A$16;"")<>"";SI(ESTNUM(EQUIV("*"&Dico!$A$2:$A$16&"*";product!F2;0))=VRAI;Dico!$A$2:$A$16;"")&"|";""));NBCAR(CONCAT(SI(SI(ESTNUM(EQUIV("*"&Dico!$A$2:$A$16&"*";product!F2;0))=VRAI;Dico!$A$2:$A$16;"")<>"";SI(ESTNUM(EQUIV("*"&Dico!$A$2:$A$16&"*";product!F2;0))=VRAI;Dico!$A$2:$A$16;"")&"|";"")))-1);"")

Sub Cles()
Dim coll  As New Collection, tablo, i&, x$, e
On Error Resume Next
tablo = [Liste].Resize(, 2) 'nom défini, au moins 2 éléments
For i = 1 To UBound(tablo)
    x = tablo(i, 1)
    coll.Add x, CStr(x)
Next i
With Range("F1", Cells(Rows.Count, "F").End(xlUp)(2)) 'matrice plus rapide, au moins 2 éléments
    tablo = .Value
    tablo(1, 1) = "Clés"
    For i = 2 To UBound(tablo) - 1
        x = ""
        For Each e In Split(tablo(i, 1))
            If IsError(coll(e)) Then Else x = x & "|" & e
        Next e
        tablo(i, 1) = Mid(x, 2)
    Next i
    .Offset(, 14) = tablo 'restitution
    .Offset(, 14).EntireColumn.AutoFit 'ajustement largeur
End With
End Sub

For Each e In Split(Replace(Replace(tablo(i, 1), ",", ""), ".", ""))

Function DicoRecherche(ByVal T) As String
Static Cn As Object
If TypeName(Cn) = "Nothing" Then
    Set Cn = CreateObject("Adodb.Connection")
    Cn.Open GenereCSTRING(Xls, Base:=ThisWorkbook.FullName, Titre:=True)
End If

T = Split(Replace(UCase(T), "'", "''"))
T = "'" & Join(T, "','") & "'"
Dim SQL As String
SQL = "Select * from [Dico$] where ucase([LISTE :]) in (" & T & ") Order by [LISTE :]"
With Cn.Execute(SQL)
    If Not .EOF Then
        DicoRecherche = .getstring(, , , "|")
        DicoRecherche = Left(DicoRecherche, Len(DicoRecherche) - 1)
    End If
End With
End Function
Sub test()
' =DicoRecherche(RC[-14])
With Sheets("product")
    Range(.Range("T2"), .Cells(.UsedRange.Rows.Count, "T")).FormulaR1C1 = "=DicoRecherche(RC[-14])"
    Range(.Range("T2"), .Cells(.UsedRange.Rows.Count, "T")).Value = Range(.Range("T2"), .Cells(.UsedRange.Rows.Count, "T")).Value
End With
End Sub

'                    dysorthographie ©
'**************************************************************************************
Public Enum separateur
    Tabulation = 0
    Virgule = 1
    PoinVirgule = 2
    Pip = 3
    Fixe = 4
End Enum
Public Enum TypeCsv
    Bit = 0         ' "Bit"
    Bool = 1        ' "Boolean"
    Bytes = 2       ' "Byte"
    Short = 3       ' "Short"
    Entier = 4      ' "Integer"
    EntierLong = 5  ' "Long"
    Signer = 6      ' "Single"
    numerique = 7   ' "Double"
    Reel = 8        ' "Float"
    Date = 9        ' "DateTime"
    Text = 10       ' "Text"
    car = 11        ' "Char"
    txt = 12        ' "Memo"
    LonTXT = 14     ' "LongChar"
End Enum

' Permet de définir quel connecteur ODBC uilise pour la connexion à la base de données !
Public Enum MyConst
    ACCESS
    ODBC
    ORACLE
    SQLSERVER2005
    SQLServer2008R2
    SQLITE
    SQLite3
    CSV
    Xls
    MySQL
    DBF
End Enum
'**************************************************************************************
'Permet de définir le type de champs
Public Enum AdodbTypeChamps
   adEmpty = 0
    adSmallInt = 2
    adInteger = 3
    adSingle = 4
    adDouble = 5
    adCurrency = 6
    adDate = 7
    adBSTR = 8
    adIDispatch = 9
    adError = 10
    adBoolean = 11
    adVariant = 12
    adIUnknown = 13
    adDecimal = 14
    adTinyInt = 16
    adUnsignedTinyInt = 17
    adUnsignedSmallInt = 18
    adUnsignedInt = 19
    adBigInt = 20
    adUnsignedBigInt = 21
    adFileTime = 64
    adGUID = 72
    adBinary = 128
    adChar = 129
    adWChar = 130
    adNumeric = 131
    adUserDefined = 132
    adDBDate = 133
    adDBTime = 134
    adDBTimeStamp = 135
    adChapter = 136
    adPropVariant = 138
    adVarNumeric = 139
    adVarChar = 200
    adLongVarChar = 201
    adVarWChar = 202
    adLongVarWChar = 203
    adVarBinary = 204
    adLongVarBinary = 205
End Enum

Public Enum CharacterSet
    ANSI = 0    'ANSI
    UTF = 1     'UTF-8
End Enum
'***************************************************************************************
'Permet de sauvegarder le Nom ainsi que  le type d'un champs
Public Type Champ
    Name As String
    TypeChamp As AdodbTypeChamps
End Type
'******************************************************************************************************************************************
'Retourne le ConetionString pour une connexion à une base de données ! _
Données d'entrées, information optionnel ! _
User : utilisateur  {Login] _
Server : Répertoire et/ou nom du serveur {SQL server, Oracle, MySQL, CSV} _
Password  mot de passe si nécessaires  {Login} _
Base : Non dela base de données et/on chemein complet {SQL server, Oracle, MySQL, EXCEL, Sqlite} _
Titre : défini si le nom des champs figure sur la première ligne du document {MySQL, EXCEL }
'******************************************************************************************************************************************
Public Function GenereCSTRING(TYPEBASE As MyConst, _
Optional User As String, _
Optional Server As String, _
Optional Password As String, _
Optional Base As String, _
Optional Titre As Boolean = False, _
Optional IMEX As Boolean = False)
'Permet de générer le Cornec String
'    ACCESS97
'    ACCESS2000
'    ACCESS2012
'    ODBC
'    ORACLE
'    SQLSERVER2005
'    SQLServer2008R2
'    SQLITE
'    SQLite3
'    CSV
'    Xls
'    MySQL

Select Case TYPEBASE
     Case Xls
            GenereCSTRING = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & Base & ";Extended Properties=""Excel 12.0;HDR=" & Array("No", "YES")(Abs(Titre)) & ";" & IIf(IMEX, "IMEX=1;", "") & """"
    Case ACCESS2012
        GenereCSTRING = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & Base & ";Jet OLEDB:Database Password=" & Password & ";"
    Case MySQL
    GenereCSTRING = " DRIVER={MySQL ODBC 5.1 Driver};SERVER=" & Server & ";UID=" & User & ";DATABASE=" & Base & ";Password=" & Password
    Case ODBC
        GenereCSTRING = "Provider=MSDASQL.1;Password=" & Password & ";Persist Security Info=True;User ID=" & User & ";Data Source=" & Base
    Case ORACLE
        GenereCSTRING = "Provider=OraOLEDB.Oracle.1;Password=" & Password & ";Persist Security Info=True;User ID=" & User & ";Data Source=" & Base
    Case SQLSERVER2005
        GenereCSTRING = "Provider=SQLOLEDB.1;Password=" & Password & ";Persist Security Info=True;User ID=" & User & ";Initial Catalog=" & Base & ";Data Source=" & Server
    Case SQLServer2008R2
        GenereCSTRING = "Provider=SQLNCLI;Server=" & Server & ";Database=" & Base & ";UID=" & User & ";PWD=" & Password & ";"
    Case SQLITE
        GenereCSTRING = "Provider=OleSQLite.SQLiteSource.3; Data Source=" & Fichier
        GenereCSTRING = "Driver={SQLite ODBC (UTF-8) Driver};Database=" & Fichier & ";StepAPI=;Timeout="
    Case SQLite3
        GenereCSTRING = "Driver={SQLite3 ODBC Driver};Database=" & Base & ";LongNames=0;Timeout=4000;NoTXN=0;SyncPragma=NORMAL;StepAPI=0;"
    Case CSV
        GenereCSTRING = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & Server & ";Extended Properties=""Text;HDR=" & Array("No", "YES")(Abs(Titre)) & ";FMT=Delimited;"""
    Case DBF
        GenereCSTRING = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & Server & ";Extended Properties=dBASE IV;User ID=" & User & ";"
    Case Else
        GenereCSTRING = "PAS ASSEZ DE PARAMETRES RENSEIGNES !!!"
End Select
End Function
'******************************************************************************************************************************************
'Ici nous avons un requêter universel ! _
Il permet  d'exécuter et/ou retourne une requête SQL {Exécution Direct Insert, Update, Delete ou de sélection} _
Paramètres : _
Sql : requête à exécuter _
 cn : connectionSting _
 Param() : paramètres de la requête par coupe de 2 _
Exeple:  setMyRequête = ExecuteRequete(" Select * From MyTable where Champ1= ? ", " Champ1 ", "Valeure ")
'******************************************************************************************************************************************
Function ExecuteRequete(SQL As String, Cn As Variant, ParamArray Param() As Variant) As Object
Dim I As Integer
With CreateObject("ADODB.Command")
    .ActiveConnection = Cn
    .CommandType = 1
    .CommandTimeout = 500
     .CommandText = SQL
    For I = LBound(Param) To UBound(Param) Step 2
        Set prm = CreateObject("ADODB.Parameter")
        prm.Name = Param(I): prm.Value = Param(I + 1): prm.Type = 12
        .Parameters.Append prm
    Next
 
    Set ExecuteRequete = .Execute
End With
End Function
Public Function OpenRecordset(SQL, Cn As Variant) As Object
'Retourne un RecordeSet
On Error Resume Next
    Dim Rs
Dim NbErr
Err.Clear
    Set OpenRecordset = CreateObject("ADODB.Recordset")
    OpenRecordset.Open SQL, Cn, 1, 3
    If Err Then
    MsgBox Err.Description
       Set OpenRecordset = Nothing
    End If
    Err.Clear
End Function
'******************************************************************************************************************************************
'Retourne la liste des tables de la base de données. _
Paramètre  Connexion : ConectionString
'******************************************************************************************************************************************
Public Function ListeTables(Connexion As Variant) As String()
Dim TBL() As String, I As Integer
With CreateObject("ADOX.Catalog")
    .ActiveConnection = Connexion
    For Each T In .Tables
        ReDim Preserve TBL(I)
        TBL(I) = T.Name
        I = I + 1
    Next
End With
    ListeTables = TBL
End Function
'******************************************************************************************************************************************
'Retourne la des champs d'une table de la base de données. _
Paramètre  Connexion : ConectionString _
          Table : Nomde la table
'******************************************************************************************************************************************
Public Function LiteChamps(Connexion As Variant, Table As String) As Champ()
Dim Ch() As Champ, I As Integer
With CreateObject("ADOX.Catalog")
    .ActiveConnection = Connexion
    For Each T In .Tables(Table).Columns
        ReDim Preserve Ch(I)
        Ch(I).Name = T.Name
        Ch(I).TypeChamp = T.Type
        I = I + 1
    Next
End With
LiteChamps = Ch
End Function
'******************************************************************************************************************************************

Public Sub ShemaIn(Fichier As String, _
                    Server As String, _
                    FichertVierge As Boolean, _
                    Kill As Boolean, _
                    Delimited As separateur, _
                    Character As CharacterSet, _
                    ColNameHeader As Boolean, _
                    DateTimeFormat As String, _
                    DecimalSymbol As String, _
                    ParamArray Champ() As Variant)
Dim txt As String, DLM, Tp
Tp = Array("Bit", "Boolean", "Byte", "Short", "Integer", "Long", "Single", "Double", "Float", "DateTime", "Text", "Char", "Memo", "LongChar")
DLM = Array("TabDelimited", "CSVDelimited", "Delimited(;)", "Delimited(|)", "FixedLength")
txt = "[" & Fichier & "]" & vbCrLf & "Format= " & DLM(Delimited) & vbCrLf & _
        "CharacterSet=" & Array("ANSI", "UTF-8")(Character) & vbCrLf & _
        "ColNameHeader=" & Array("False", "True")(Abs(ColNameHeader)) & vbCrLf & _
        "DateTimeFormat=" & DateTimeFormat & vbCrLf & _
         "DecimalSymbol=" & Chr(34) & DecimalSymbol & Chr(34) & vbCrLf
       
        For Each F In Champ
            For I = LBound(F, 1) To UBound(F, 1)
            txt = txt & F(I, 1) & "=" & F(I, 2) & " " & Tp(F(I, 3)) & " Width " & F(I, 4) & vbCrLf
            Next
        Next
With CreateObject("Scripting.FileSystemObject")
    With .OpenTextFile(Server & "\schema.ini", IIf(Kill, 2, 8), True)
        .Write txt
        .Close
    End With
    If FichertVierge Then
        With .OpenTextFile(Server & "\" & Fichier, 2, True)
            .Close
        End With
    End If
End With
End Sub

let
    Source = Excel.CurrentWorkbook(){[Name="T_Data"]}[Content],
    TypeText = Table.TransformColumnTypes(Source,{{"nombre", type text}}),
    Intersect = Table.AddColumn(TypeText, "Mots_Cles", each List.Intersect({Text.Split([nombre]," "),T_Liste[Liste]})),
    Final = Table.TransformColumns(Intersect, {"Mots_Cles", each Text.Combine(List.Transform(_, Text.From), "|"), type text})[[Mots_Cles]]
in
    Final

IdCat = TabCat(i, 1) 'on récupère l'ID

IdCat = " " &TabCat(i, 1) &" " 'on récupère l'ID

chaine = chaine & Chr(10) & ele

chaine = chaine & "|" & ele

Option Explicit
'---------------------------------------------------------------------------------------
' Procédure : RechMotDico
' Auteur    : [Laurent950]
' Date      : [10-07-2024]
' But       : Recherche des mots spécifiés dans une chaîne de caractères et retourne une liste des mots trouvés.
'---------------------------------------------------------------------------------------
' Description :
' Cette fonction recherche des mots spécifiés dans une chaîne de texte et retourne une liste des mots trouvés.
'
' Paramètres :
' Plage - La plage de cellules contenant les mots à rechercher.
' Texte - La chaîne de texte dans laquelle effectuer la recherche.
'
' Retourne :
' Une chaîne contenant les mots trouvés, séparés par un caractère pipe (|).
'---------------------------------------------------------------------------------------

' Cette procédure configure les options de la fonction, y compris les infobulles.
Sub ConfigureRechMotDico()
    Application.MacroOptions _
        Macro:="RechMotDico", _
        Description:="Recherche des mots spécifiés dans une chaîne de caractères et retourne une liste des mots trouvés.", _
        Category:="Texte", _
        ArgumentDescriptions:=Array("La plage de cellules contenant les mots à rechercher", "La chaîne de texte dans laquelle effectuer la recherche")
End Sub

Function RechMotDico(Plage As Range, Texte As String) As String
    Dim Matches As Object
    Dim Match As Object
    Dim i As Long
    Dim reg As Object
    Set reg = CreateObject("VBScript.RegExp")

    Dim CherchePattern As String  ' La cible caractères recherchés par Pattern
    Dim DicoListe As String
    DicoListe = "" ' Initialisation de DicoListe

    Dim Rng As Range
    For Each Rng In Plage
        ' Construction du pattern pour la recherche exacte
        CherchePattern = "(^|\s)" & Rng.Value2 & "(\b|\s|$)"

        ' Configuration des propriétés de l'objet RegExp
          reg.Pattern = CherchePattern
          reg.MultiLine = True
          reg.IgnoreCase = False
          reg.Global = True

        ' Test du pattern sur le texte de la cellule
          Debug.Print reg.Test(Texte) ' Remplacé Rng.Text par S

        ' Exécution de la recherche
          Set Matches = reg.Execute(Texte) ' Remplacé Rng.Text par S

        ' Parcours des résultats
            For Each Match In Matches
                Debug.Print "source >>", Match.Value
                For i = 0 To Match.SubMatches.Count - 1
                    Debug.Print "[$" & i + 1 & "]", Match.SubMatches(i)
                Next i
                ' Ajout des résultats à DicoListe
                DicoListe = DicoListe & Match.Value & "|"
            Next Match
    Next Rng

    ' Suppression du dernier caractère "|" si DicoListe n'est pas vide
        If Len(DicoListe) > 0 Then
            DicoListe = Left(DicoListe, Len(DicoListe) - 1)
        End If

    ' Retourner la liste des mots trouvés
        RechMotDico = DicoListe

    ' Libération d'objets
        Set Matches = Nothing
        Set Match = Nothing
        Set reg = Nothing
End Function

Intersect = Table.AddColumn(TypeText, "Mots_Cles",
                each List.Intersect({Splitter.SplitTextByAnyDelimiter({" ",",",";","."})([nombre]),
                T_Liste[Liste]})),

Sub ExecuteT_Final()
    ActiveWorkbook.Connections("Requête - T_Final").Refresh
End Sub

Sub M_A_J()
Range("T_Final").ListObject.QueryTable.Refresh False 'ou True si je veux faire la mise à jour en arrière plan
End Sub