Microsoft 365 Recherche de certains caractères dans cellule

[netparty]

Bonjour à tous

Je suis à la recherche d’une macro pour vérifier si il y a des caractères interdits dans une plage de cellule.
Les caractères à vérifier sont les suivant \ / : * ? " < >
La sélection des cellule se fait soit directement par sélection dans la feuille ou via les textbox du formulaire textbox1 pour la cellule de départ et textbox2 pour la cellule de fin.

Le 1er bouton sert à vérifier l’existence des caractères \ / : * ? " < > présent dans les cellules si il y a ces caractères alors la cellule est mise en rouge.
A l’aide d’un 2ième bouton, j’aimerai que les caractères <> soient supprimé.

Merci d'avance

 

[job75]

Bonjour netparty,

Utiliser un UserForm c'est bien lourd, il vaut mieux une InputBox.

Voyez le fichier joint et les macros des boutons :

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 = "\/:*?""<>"
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 = "\/:*?""<>"
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

A+

 

[sylvanu]

Bonsoir Netparty, Job,
Un essai en PJ.

1- Sélectionnez la plage désirée

2- Appuyer sur le bouton

 

[netparty]

Bonjour job75 , sylvanu

Merci à vous 2 deux pour votre code, après la correction et le suppression des caractères interdit est-possible de supprimer les espaces ou se trouvais ces caractères ?

@ sylvanu après la correction est-il possible de remettre la cellule dans sa couleur d'origine

Merci

 

[sylvanu]

Je ne mémorise pas la couleur de toutes les cellules.
Mais on peut repasser en noir à la fin.

 

[netparty]

Je ne mémorise pas la couleur de toutes les cellules.
Mais on peut repasser en noir à la fin.

Merci c'est impeccable.

Bonne soirée

 

[job75]

après la correction et le suppression des caractères interdit est-possible de supprimer les espaces ou se trouvais ces caractères ?

Pour supprimer les espaces encadrant un caractère interdit voyez ce fichier (2) :

For Each r In r
    x = r
    For i = Len(x) To 1 Step -1
        If d.exists(Mid(x, i, 1)) Then x = Trim(Left(x, i - 1)) & Trim(Mid(x, i + 1))
    Next i
    r = x
Next r

 

[netparty]

Pour supprimer les espaces encadrant un caractère interdit voyez ce fichier (2) :

For Each r In r
    x = r
    For i = Len(x) To 1 Step -1
        If d.exists(Mid(x, i, 1)) Then x = Trim(Left(x, i - 1)) & Trim(Mid(x, i + 1))
    Next i
    r = x
Next r

Merci pour ton aide

Bonne soirée