Microsoft 365 supprimer caractères dans une chaine

Usine à gaz

XLDnaute Barbatruc
Supporter XLD
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,
 

Pièces jointes

  • det_suppr_test.xlsm
    25 KB · Affichages: 9

sylvanu

XLDnaute Barbatruc
Supporter XLD
Euh ... G2 est la cellule G2. :)
1637141546479.png


Oui j'ai ouvert le fichier.:(
 

sylvanu

XLDnaute Barbatruc
Supporter XLD
Strictement la même chose en VBA :
VB:
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
 

Pièces jointes

  • det_suppr_test (2).xlsm
    20.5 KB · Affichages: 2

Usine à gaz

XLDnaute Barbatruc
Supporter XLD
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 :)
 

Pièces jointes

  • det_suppr_test (2).xlsm
    21.1 KB · Affichages: 5
Dernière édition:

sylvanu

XLDnaute Barbatruc
Supporter XLD
Re Lionel,
Un essai en PJ avec :
VB:
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
 

Pièces jointes

  • det_suppr_test (5).xlsm
    22.9 KB · Affichages: 4

Usine à gaz

XLDnaute Barbatruc
Supporter XLD
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,
 

Discussions similaires

Réponses
37
Affichages
833

Statistiques des forums

Discussions
298 027
Messages
1 965 281
Membres
200 894
dernier inscrit
Sneaks