XL 2019 Supprimer des mots d'une chaine de caractère

Function Suppr_Mots(Chaine As String) As String
    Dim i As Long, DerLig_f2 As Long, Pos
    Dim f2 As Worksheet
    Dim Texte As String
    Set f2 = Sheets("Liste_Exp")
    DerLig_f2 = f2.Range("A" & Rows.Count).End(xlUp).Row
    For i = 1 To DerLig_f2
        Texte = f2.Cells(i, "A")
        Pos = InStr(1, Chaine, Texte, 1)
        If Pos <> 0 Then Chaine = Application.WorksheetFunction.Replace(Chaine, Pos, Len(Texte), " ")
    Next i
    Suppr_Mots = Chaine
End Function

Function reduction(ByVal xquoi As String, xliste As Range) As String
Const lettres = "eaisnrtoludcmpégbvhfqyxjèàkwzêçôâîûùïáüëöíœ@žð"
Dim Liste, Letr, x, deb&, n&

If xliste.Count > 1 Then Liste = xliste.Value Else ReDim Liste(1 To 1, 1 To 1): Liste = xliste.Value
xquoi = "#" & xquoi & "#"
For Each x In Liste
   deb = 1
   Do
      n = InStr(deb, xquoi, x, vbTextCompare)
      If n = 0 Then Exit Do
      If Not estlettre(Mid(xquoi, n - 1, 1)) And Not estlettre(Mid(xquoi, n + Len(x), 1)) Then
         xquoi = Replace(xquoi, x, " ", , 1, vbTextCompare)
      End If
      deb = n + Len(x)
   Loop
Next x
   reduction = Application.Trim(Mid(xquoi, 2, Len(xquoi) - 2))
End Function

Function estlettre(x As String) As Boolean
Const lettres = "eaisnrtoludcmpégbvhfqyxjèàkwzêçôâîûùïáüëöíœ@žð"
   estlettre = InStr(1, lettres, Left(x, 1), vbTextCompare) > 0
End Function

Function Remplacement(Numéro As String, Chaine As String, Plage As Range)
    Dim c As Range, Texte As String
    For Each c In Plage
        Texte = c
        Chaine = Application.Substitute(Chaine, Texte, "")
        Texte = LCase(c)                                    ' Si minuscules
        Chaine = Application.Substitute(Chaine, Texte, "")
        Texte = UCase(c)                                    ' Si majuscules
        Chaine = Application.Substitute(Chaine, Texte, "")
    Next
    Remplacement = Numéro & " " & Chaine
End Function