Microsoft 365 supprimer caractères dans une chaine

[Usine à gaz]

Bonjour à toutes et à tous,
Je vous souhaite une belle journée

J'avais récupéré ces codes qui fonctionnent très bien.

Option Explicit

Sub Detecter()
Dim r As Range, interdit$, d As Object, i%, x$
Application.DisplayAlerts = False
On Error Resume Next
Set r = Application.InputBox("Sélectionnez une plage :", Type:=8)
On Error GoTo 0
If r Is Nothing Then Exit Sub
Application.ScreenUpdating = False
Cells.Interior.ColorIndex = xlNone 'RAZ
Set r = Intersect(r, ActiveSheet.UsedRange)
If r Is Nothing Then Exit Sub
interdit = "ABCDEFGHIJKLMNOPQSTUWVXYZÉÈabcdefghijklmqstwvxyzè1234567890: -"
Set d = CreateObject("Scripting.Dictionary")
For i = 1 To Len(interdit)
    d(Mid(interdit, i, 1)) = ""
Next
For Each r In r
    x = r
    For i = 1 To Len(x)
        If d.exists(Mid(x, i, 1)) Then r.Interior.ColorIndex = 3: Exit For
Next i, r
End Sub

Sub Supprimer()
Dim r As Range, interdit$, d As Object, i%, x$
Application.DisplayAlerts = False
On Error Resume Next
Set r = Application.InputBox("Sélectionnez une plage :", Type:=8)
On Error GoTo 0
If r Is Nothing Then Exit Sub
Application.ScreenUpdating = False
Set r = Intersect(r, ActiveSheet.UsedRange)
If r Is Nothing Then Exit Sub
r.Interior.ColorIndex = xlNone 'RAZ
interdit = "ACDEFGHIKLMNPQSTWVXYZÉÈacdeéfghiklmpqstwvxyzè1234567890: -"
Set d = CreateObject("Scripting.Dictionary")
For i = 1 To Len(interdit)
    d(Mid(interdit, i, 1)) = ""
Next
For Each r In r
    x = r
    For i = Len(x) To 1 Step -1
        If d.exists(Mid(x, i, 1)) Then x = Left(x, i - 1) & Mid(x, i + 1)
    Next i
    r = x
Next r
End Sub
Public Function Nb_Occurence(strInput As String, strFind As String) As Double
If strFind <> "" Then
    Nb_Occurence = (Len(strInput) - Len(Replace(strInput, strFind, ""))) / Len(strFind)
End If
End Function

je remercie encore son auteur

Dans l'exemple fichier joint, le code me laisse bien mon "Bonjour,"
Mais il me laisse aussi toutes les lettes identiques (contenues dans mon Bonjour,) "u,on,ouon,
u,onouonbnn, our urournbrn. nornrrn, uurrouonn,"

je n'arrive à trouver à coder pour ne laisser que le "Bonjour,".

Auriez-vous le bon code ?
Fichier test joint.
Je vous remercie,
Amicalement,
lionel,

 

[sylvanu]

Bonjour Usine à gaz,
S'il s'agit simplement de tout nettoyer saur Bonjour, pourquoi pas tout simplement en G2 mettre :

=SI(NB.SI(F2;"*Bonjour*")=1;"Bonjour,";F2)

 

[Usine à gaz]

Bonjour Sylvanu,
Merci d'être là
C'est koi G2 ?
As-tu ouvert le fichier ?

 

[sylvanu]

Euh ... G2 est la cellule G2.

Oui j'ai ouvert le fichier.

 

[Usine à gaz]

Je comprends mieux
Mais c'est pas possible car c'est dans les cellules remplies que j'ai besoin de faire l'opération

 

[sylvanu]

Strictement la même chose en VBA :

Sub Supprimer2()
Dim r As Range, interdit$, d As Object, i%, x$
Application.DisplayAlerts = False
On Error Resume Next
Set r = Application.InputBox("Sélectionnez une plage :", Type:=8)
On Error GoTo 0
If r Is Nothing Then Exit Sub
Application.ScreenUpdating = False
Set r = Intersect(r, ActiveSheet.UsedRange)
If r Is Nothing Then Exit Sub
r.Interior.ColorIndex = xlNone 'RAZ
If Application.CountIf(r, "*Bonjour*") > 0 Then r = "Bonjour,"
End Sub

 

[Usine à gaz]

Merci Sylvanu
Je vais regarder,
lionel,

 

[Usine à gaz]

Re Syvanu,
Merci et ça fonctionne super bien

On pourrait aller plus loin ? :
Dans les cellules, il pourra y avoir plusieurs "Bonjour," voir 3-4-5 ou plus.
Il faudrait qu'il me garde les "Bonjour," autant de fois qu'ils sont dans la cellule.
Je joins ton fichier retourné dans lequel j'ai modifié le contenu des cellules,
Merci à toi

 

[sylvanu]

Re Lionel,
Un essai en PJ avec :

Sub Supprimer()
Dim r As Range, interdit$, d As Object, i%, x$, tablo, Chaine$
Application.DisplayAlerts = False: On Error Resume Next
Set r = Application.InputBox("Sélectionnez une plage :", Type:=8)
On Error GoTo 0
If r Is Nothing Then Exit Sub
Application.ScreenUpdating = False
Set r = Intersect(r, ActiveSheet.UsedRange)
If r Is Nothing Then Exit Sub
r.Interior.ColorIndex = xlNone 'RAZ
For Each r In r
    If Application.CountIf(r, "*Bonjour*") > 0 Then
        Chaine = "": tablo = Split(r, " ")
        For i = 0 To UBound(tablo)
            If tablo(i) Like "*Bonjour*" Then Chaine = Chaine & "Bonjour, "
        Next i
        r = Chaine
    End If
Next r
End Sub

 

[Usine à gaz]

Re-Sylvanu,

C'est super = essai transformé
Un grand merci
ça devait être coton ? lol
lionel,

 

[sylvanu]

Par contre je n'ai pas compris la complexité du code qui existait.
Il était fait pour ça ?

 

[Usine à gaz]

Moi non plus car je suis nul en vba ... juste un bricoleur lol
Ton code fonctionne super bien. Merci

J'ose en tenter une dernière.
J'ai, juste pour tester, voulu exécuter le code avec plusieurs mots et là, ça ne fonctionne plus.
Crois-tu que ce soit possible ?
Si trop compliqué, laisses tomber car je n'en ai pas besoin ... c'est pour savoir, en cas de besoin dans l'avenir.

Merci Sylvanu
lionel,

 

[sylvanu]

avec plusieurs mots

Comment cela ?
Dans une même cellule avec Bonjour ET Bonsoir ?

 

[Usine à gaz]

Par exemple avec "J'ai ma cravache" qui est dans G4

 

[sylvanu]

Dans la PJ, G4 est vide.

Dans une même cellule avec Bonjour ET Bonsoir ?

C'est bien cela ? On supprime tout sauf les Bonjour et Bonsoir par ex ?