XL 2016 identifier chaine de caractère dans une cellule et ramener une donnée d'une table de correspondance

Sub RechercheMotCle()
    Dim wsDonnees As Worksheet
    Dim wsMotsCles As Worksheet
    Dim rngDonnees As Range
    Dim rngMotsCles As Range
    Dim dict As Object
    Dim data As Variant
    Dim i As Long
    Dim mot As Variant
    Dim motTrouve As String

    ' Désactiver certaines fonctionnalités pour améliorer les performances
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    Application.EnableEvents = False

    ' Feuilles de travail
    Set wsDonnees = ThisWorkbook.Sheets("données")
    Set wsMotsCles = ThisWorkbook.Sheets("TABLE MOTS CLES")

    ' Plages de données
    Set rngDonnees = wsDonnees.Range("E2:E" & wsDonnees.Cells(wsDonnees.Rows.Count, "E").End(xlUp).Row)
    Set rngMotsCles = wsMotsCles.Range("B2:C" & wsMotsCles.Cells(wsMotsCles.Rows.Count, "B").End(xlUp).Row)

    ' Créer un dictionnaire pour stocker les mots clés et leurs valeurs associées
    Set dict = CreateObject("Scripting.Dictionary")
    For Each mot In rngMotsCles
        dict(mot.Value) = mot.Offset(0, 1).Value
    Next mot

    ' Stocker les données dans un tableau
    data = rngDonnees.Value

    ' Parcourir chaque cellule dans le tableau
    For i = 1 To UBound(data, 1)
        motTrouve = ""
        ' Parcourir chaque mot clé dans le dictionnaire
        For Each mot In dict.Keys
            ' Si le mot clé est trouvé dans la cellule
            If InStr(1, data(i, 1), mot, vbTextCompare) > 0 Then
                ' Stocker la valeur associée
                motTrouve = dict(mot)
                Exit For
            Else
                motTrouve = "Pas trouvé"
            End If
        Next mot
        ' Copier la valeur associée en colonne H
        data(i, 1) = motTrouve
    Next i

    ' Écrire les résultats dans la colonne H
    wsDonnees.Range("H2:H" & wsDonnees.Cells(wsDonnees.Rows.Count, "E").End(xlUp).Row).Value = data

    ' Réactiver les fonctionnalités désactivées
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    Application.EnableEvents = True
End Sub