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,

 

[patricktoulon]

re
j'ai fait un truc similaire mais avec bonjour et bonsoir en meme temps
en travaillant sur le split de la chaîne avec un like inversé
dans la boucle
if not " Bonjour Bonsoir " like "*" & tbl(i) & "*" then tbl(i)=""
et en sortie
x=application.trim(join(tbl))
et il sont dans le même ordre
une seule boucle un seul test like pour X mots

 

[Usine à gaz]

Re,

Une autre solution, plus rapide car on travaille sur un tableau VBA :

Sub Supprimer()
Dim P As Range, texte$, L%, tablo, i&, x$, n%
Set P = [D1].CurrentRegion 'à adapter
texte = "Bonjour" 'à adapter
L = Len(texte)
tablo = P.Resize(, 2) 'matrice, plus rapide, au moins 2 éléments
For i = 2 To UBound(tablo)
    x = tablo(i, 1)
    n = (Len(x) - Len(Replace(x, texte, ""))) / L
    x = Application.Rept(", " & texte, n)
    tablo(i, 1) = Mid(x, 3)
Next
P = tablo 'restitution
End Sub

Testée en dupliquant le tableau D2: D7 sur 12000 lignes, chez moi la macro s'exécute en 1,7 seconde.

A+

Bonsoir Gérard, Sylvanu, Patrick
Effectivement : super rapide l'éclair lol

 

[Usine à gaz]

Bonsoir Gérard, Sylvanu, Patrick
Effectivement : super rapide l'éclair lol

Bonjour Gérard, le Forum
@ Gérard :
Ton "Speedy" code fonctionne super bien et je t'en remercie
J'ai une question (de confort) :
Plutôt que d'aller chaque fois modifier le code si le ou les mots changent,
serait-il possible de lier le code à la valeur de la cellule B1 ?
Quand je le modifie :

Option Explicit

Sub Supprimer()
Dim P As Range, texte$, L%, tablo, i&, x$, n%
Set P = [D1].CurrentRegion 'à adapter
texte = [b1].Value 'à adapter
L = Len(texte)
tablo = P.Resize(, 2) 'matrice, plus rapide, au moins 2 éléments
For i = 2 To UBound(tablo)
    x = tablo(i, 1)
    n = (Len(x) - Len(Replace(x, texte, ""))) / L
    x = Application.Rept(", " & texte, n)
    tablo(i, 1) = Mid(x, 3)
Next
P = tablo 'restitution
End Sub

ça fonctionne plus :
j'ai tenté de le modifier mais je n'ai pas réussi

 

[Usine à gaz]

Bonjour Gérard, le Forum
@ Gérard :
Ton "Speedy" code fonctionne super bien et je t'en remercie
J'ai une question (de confort) :
Plutôt que d'aller chaque fois modifier le code si le ou les mots changent,
serait-il possible de lier le code à la valeur de la cellule B1 ?
Quand je le modifie :

Option Explicit

Sub Supprimer()
Dim P As Range, texte$, L%, tablo, i&, x$, n%
Set P = [D1].CurrentRegion 'à adapter
texte = [b1].Value 'à adapter
L = Len(texte)
tablo = P.Resize(, 2) 'matrice, plus rapide, au moins 2 éléments
For i = 2 To UBound(tablo)
    x = tablo(i, 1)
    n = (Len(x) - Len(Replace(x, texte, ""))) / L
    x = Application.Rept(", " & texte, n)
    tablo(i, 1) = Mid(x, 3)
Next
P = tablo 'restitution
End Sub

ça fonctionne plus :
j'ai tenté de le modifier mais je n'ai pas réussi

je pense avoir trouvé, ça semble fonctionner :

Option Explicit

Sub Supprimer()
Dim P As Range, texte$, L%, tablo, i&, x$, n%
Set P = Range([d2], Cells(Rows.Count, "d").End(xlUp)) '[D1].CurrentRegion 'à adapter
texte = [b2].Value 'à adapter
L = Len(texte)
tablo = P.Resize(, 2) 'matrice, plus rapide, au moins 2 éléments
For i = 1 To UBound(tablo)
    x = tablo(i, 1)
    n = (Len(x) - Len(Replace(x, texte, ""))) / L
    x = Application.Rept(", " & texte, n)
    tablo(i, 1) = Mid(x, 3)
Next
P = tablo 'restitution
End Sub