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
Je n'avais pas compris "J'ai ma cravache". :rolleyes:
Un essai en PJ. Ca complique un peu les choses. Mais il suffit de remplacer "J'ai ma cravache" par "£" par ex, puis à la fin remplacer les £ par la phrase. et ca marche.
VB:
For Each r In r
    If Application.CountIf(r, "*J'ai ma cravache*") > 0 Then
        r = Replace(r, "J'ai ma cravache", "£")
        Chaine = "": tablo = Split(r, " ")
        For i = 0 To UBound(tablo)
            If tablo(i) Like "*£*" Then Chaine = Chaine & "J'ai ma cravache, "
        Next i
        r = Chaine
    End If
Next r
 

Pièces jointes

  • det_suppr_test (7).xlsm
    23.1 KB · Affichages: 2

Usine à gaz

XLDnaute Barbatruc
Supporter XLD
Bonjour Sylvanu, le Forum,
je vous souhaite une belle journée :)

@sylvanu :
Ton code fonctionne super bien et je t'en remercie :)
J'ai une dernière 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 ?

Merci à toi :)
je joins le fichier test,
lionel :)
 

Pièces jointes

  • Repondeurs_Sylvanu_multiMots2.xlsm
    25.4 KB · Affichages: 2

sylvanu

XLDnaute Barbatruc
Supporter XLD
Bonjour,
Il suffit de changer ces lignes de codes en remplaçant la phrase par B1 :
VB:
    If Application.CountIf(r, "*" & [B1] & "*") > 0 Then
        r = Replace(r, [B1], "£")
        Chaine = "": tablo = Split(r, " ")
        For i = 0 To UBound(tablo)
            If tablo(i) Like "*£*" Then Chaine = Chaine & [B1] & ", "
        Next i
        r = Chaine
    End If
 

Pièces jointes

  • Repondeurs_Sylvanu_multiMots2.xlsm
    24.9 KB · Affichages: 2

patricktoulon

XLDnaute Barbatruc
bonjour
ça délire grave ici
il faudra m'expliquer le besoin de stocker l'alphabet en min et maj et boucler sur le len de chaque valeur
dans la sub détecter
il faudra m'expliquer aussi pourquoi remettre la feuille complète en couleur xlnone alors que le usedrange suffit
il faudra m'expliquer pourquoi tester min et maj alors que tester un like sur le lcase de la valeur complète suffit aussi

autant aller droit au but avec like motif
VB:
Sub Detecter()
    Dim r As Variant
    Application.DisplayAlerts = False
    On Error Resume Next
    Set r = Application.InputBox("Sélectionnez une plage :", Type:=8)
    If r Is Nothing Then Err.Clear: Exit Sub
    Set r = Intersect(r, ActiveSheet.UsedRange)
    Application.ScreenUpdating = False
    ActiveSheet.UsedRange.Interior.ColorIndex = xlNone    'RAZpas besoins de revoir toute la feuille
    For Each r In r
        If LCase(r.Value) Like "*[a-z,0-9,é,è]*" Then r.Interior.ColorIndex = 3
    Next r
End Sub
purée j'ai moins le tournis d'un coup là ;)c'est plus light
mais vu le test je me demande si simplement un test plein ne suffirait il pas car les autre caracteres sont tres peu present me semble t il ;)
 

job75

XLDnaute Barbatruc
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+
 

Pièces jointes

  • Test(1).xlsm
    22.3 KB · Affichages: 3

Discussions similaires

Réponses
5
Affichages
125

Statistiques des forums

Discussions
311 725
Messages
2 081 941
Membres
101 847
dernier inscrit
Djigbenou