Microsoft 365 supprimer caractères dans une chaine

Usine à gaz · 17 Novembre 2021

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

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

VB:

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 · 17 Novembre 2021

Un essai en PJ avec Bonjour ET Bonsoir. Testez la cellule D2.

patricktoulon · 19 Novembre 2021

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 · 19 Novembre 2021

job75 à dit:
Re,

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

VB:

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 · 20 Novembre 2021

Usine à gaz à dit:
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 :

VB:

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 · 20 Novembre 2021

Usine à gaz à dit:
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 :

VB:

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 :

VB:

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

Microsoft 365 supprimer caractères dans une chaine

Usine à gaz

XLDnaute Barbatruc

Pièces jointes

sylvanu

patricktoulon

XLDnaute Barbatruc

Usine à gaz

XLDnaute Barbatruc

Usine à gaz

XLDnaute Barbatruc

Usine à gaz

XLDnaute Barbatruc

Discussions similaires