Microsoft 365 Suppression de caractères non visibles

[DanB34]

Bonsoir,
Il est arrive qu'il y ait des caractères non visibles (retour chariot, espace)... qui posent problème et qui par définition sont difficilement détectables.
L'idée est de les rechercher et de les supprimer.
Le code ci-dessous, récupéré sur un forum fait le travail, mais effectue la recherche sur toutes les cellules, ce qui peut être long.
J'aimerais limiter le traitement aux cellules comportant des caractères non visibles et pas boucler sur toutes les cellules de la feuille.

Sub Remplace_Caracteres_Invisibles
Dim pl As Range, c As Range
Dim car, tmp, i As Long
car = Array(8, 10, 13, 160)
Set pl = ActiveSheet.UsedRange.SpecialCells(xlCellTypeConstants, xlTextValues)
For Each c In pl
    tmp = c.Value
    For i = 0 To UBound(car)
        tmp = Replace(tmp, Chr(car(i)), " ")
    Next i
    c = Application.Trim(tmp)
Next c

Le code suivant repère et sélectionne les cellules comportant des caractères invisibles

Range("B13:G100").SpecialCells(2).Select

Mon problème : je ne parviens pas à associer ces 2 parties pour que les cellules traitées ne soient que celles concernant des caractères non visibles.
Peut-être que ce n'est pas possible ?
Merci d'avance pour vos conseils.
Dan

 

[Dudu2]

Bonjour,

Il n'existe pas de XlCellType pour désigner des cellules contenant des caractères non visibles.
Voir la liste des types ici à laquelle on peut ajouter une 2ème valeur quand le type est xlCellTypeConstants ou xlCellTypeFormulas, dont la liste est ici.

Donc ActiveSheet.UsedRange.SpecialCells(xlCellTypeConstants, xlTextValues) est la meilleure méthode pour désigner les cellules candidates à une épuration de caractères particuliers.

A noter que la fonction remplace Back Space (8), Line Feed (10), Carriage Return (13) et Non-breaking space (160). Line Feed est utile à l'affichage.

Pour supprimer les caractères de contrôle:

Sub a()
    [A1].Value = "abc" & Chr(8) & "def" & Chr(20) & "ghi"
End Sub

Sub SupprimeCaracteresDeContrôle()
    Dim Rng As Range
    Dim Cel As Range
    Dim vn As Integer
    Dim vs As String
    Dim i As Integer
    Dim k As Integer
    Dim Change As Boolean
 
    Set Rng = ActiveSheet.UsedRange.SpecialCells(xlCellTypeConstants, xlTextValues)
    'MsgBox Rng.Address
 
    Application.ScreenUpdating = False
 
    For Each Cel In Rng
        vs = Cel.Value
        i = 1
        k = Len(vs)
        Change = False
        Do While i <= k
            vn = Asc(Mid(vs, i, 1))
            If vn < 32 And vn <> 10 Then
                'MsgBox vn
                vs = Replace(vs, Chr(vn), "")
                k = Len(vs)
                Change = True
            Else
                i = i + 1
            End If
        Loop
        If Change Then Cel.Value = vs
    Next Cel
 
    Application.ScreenUpdating = True
End Sub

 

[Dudu2]

Ou pour un traitement beaucoup plus rapide (ça va 5 à 8 fois plus vite en utilisant des tableaux chargés à partir de Ranges qu'en faisant référence aux cellules individuellement)

'-------------------------------------------
'Retire les caractères de contrôle (sauf LF)
'de la feuille active
'-------------------------------------------
Sub SupprimeCaracteresDeContrôle()
    Dim Rng As Range
    Dim Area As Range
    Dim TabCells As Variant
    Dim i As Integer
    Dim j As Integer
    Dim Change As Boolean
    
    Set Rng = ActiveSheet.UsedRange.SpecialCells(xlCellTypeConstants, xlTextValues)
    If Rng Is Nothing Then Exit Sub
    'MsgBox Rng.Address
    
    Application.ScreenUpdating = False
    
    For Each Area In Rng.Areas
        If Area.Cells.Count = 1 Then
            ReDim TabCells(1 To 1, 1 To 1)
            TabCells(1, 1) = Area.Value
        Else
            TabCells = Area.Value
        End If
        Change = False
        
        For i = 1 To UBound(TabCells, 1)
            For j = 1 To UBound(TabCells, 2)
                Change = Change Or RemoveControlChars(TabCells(i, j))
            Next j
        Next i
        
        'Si modification dans l'Area, valoriser ses cellules
        If Change Then Area.Value = TabCells
    Next Area
    
    Application.ScreenUpdating = True
End Sub

'---------------------------------------------
'Retire les caractères de contrôle (sauf LF)
'de la chaine de caractère passée en paramètre
'---------------------------------------------
Private Function RemoveControlChars(Valeur As Variant) As Boolean
    Dim AscChar As Integer
    Dim i As Integer
    Dim Nb As Integer
    Dim Change As Boolean
    
    'Init Return Value
    RemoveControlChars = False
    
    If VarType(Valeur) <> vbString Then Exit Function
    
    i = 1
    Nb = Len(Valeur)
    Change = False
    
    Do While i <= Nb
        AscChar = Asc(Mid(Valeur, i, 1))
        If AscChar < 32 And AscChar <> 10 Then
            Valeur = Replace(Valeur, Chr(AscChar), "")
            Nb = Len(Valeur)
            Change = True
        Else
            i = i + 1
        End If
    Loop
    
    'Return Value
    RemoveControlChars = Change
End Function

 

[dysorthographie]

bonjour,
et tout simplement comme ça?

Dim car, i As Long
car = Array(8, 10, 13, 160)
Set pl = ActiveSheet.UsedRange.SpecialCells(xlCellTypeConstants, xlTextValues)
For i = 0 To UBound(car)
    pl.Replace Chr(car(i)), " "
Next

 

[DanB34]

Bonjour,
Merci Dudu2 pour toutes ces explications que je ne comprends malheureusement qu'en partie. Le passage par des variables tableau est effectivement beaucoup plus rapide.
Il manque une fonctionnalité existante dans la version initiale qui supprimait les espaces en double, triple... et je ne vois pas trop comment l'ajouter dans le code.
En tout cas, merci beaucoup pour le temps passé et les explications.

 

[DanB34]

Bonjour dysorthographie,
Merci pour cette proposition. Je viens de tester et j'ai une erreur d'exécution 13 (incompatibilité de type). J'ai sûrement mal compris quelque chose.

 

[dysorthographie]

Dim car, i As Long
car = Array(8, 10, 13, 160)
Set pl = ActiveSheet.UsedRange.SpecialCells(xlCellTypeConstants, xlTextValues)
For i = 0 To UBound(car)
    pl.Replace Chr(car(i)), " "
Next

'Il manque une fonctionnalité existante dans la version initiale qui supprimait les espaces en double, triple...
Set toto = pl.Find("  ", LookIn:=xlValues)
While Not (toto Is Nothing)
    pl.Replace "  ", " "
    Set toto = pl.Find("  ", LookIn:=xlValues)
Wend

 

[Dudu2]

Il manque une fonctionnalité existante dans la version initiale qui supprimait les espaces en double, triple... et je ne vois pas trop comment l'ajouter dans le code.

Si la version initiale supprimait ces espaces multiples c'est que les cellules contiennent des Non-breaking space (160).

Dans ce cas, modifier l'instruction:

If AscChar < 32 And AscChar <> 10 Then

Par:

If (AscChar < 32 And AscChar <> 10) or AscChar = 160 Then

Ceci dit, que ce soit dans la version initiale ou ce code, le remplacement du Non-breaking space (160) par rien, peut poser le problème de l'espace entre des mots qui sera supprimé. Si ça pose problème, dis-le et je ferai une fonction dédiée pour remplacer ces répétitions de vrai space (32) ou Non-breaking space (160) en 1 seul vrai space (32).

 

[DanB34]

Quand il y a 2 espaces ou plus, la procédure ne fonctionne pas.

 

[Dudu2]

C'est à dire ? Les plombs sautent ? La télé affiche la mire de l'ORTF ? Autre ?

Essaie le dernier code de dysorthographie.

 

[DanB34]

Bonjour,
Tu es devin Dudu2 ! La télé affiche effectivement la mire de l'ORTF
Laisse tomber l'informatique et prend le relais de Mme Soleil ;-)

Pour le code de dysorthographie, il reste un tout petit problème, que je n'ai malgré tout pas réussi à régler :-(
Lorsqu'il y a une ou plusieurs espaces en début de cellule, elles ne sont pas supprimées.
Encore merci pour votre aide.
Dan

 

[dysorthographie]

Bonjour,
pour finir je ne vois pas autre chose qu'une boucle!

Sub Remplace_Caracteres_Invisibles()


Dim car, i As Long
car = Array(8, 10, 13, 160)
Set pl = ActiveSheet.UsedRange.SpecialCells(xlCellTypeConstants, xlTextValues)
For i = 0 To UBound(car)
    pl.Replace Chr(car(i)), " "
Next


'Il manque une fonctionnalité existante dans la version initiale qui supprimait les espaces en double, triple...
Set toto = pl.Find("  ", LookIn:=xlValues)
While Not (toto Is Nothing)
    pl.Replace "  ", " "
    Set toto = pl.Find("  ", LookIn:=xlValues)
Wend
For Each c In pl
c.Value = Trim(c.Value)
Next

  End Sub

 

[DanB34]

Merci beaucoup. Tout est OK.
Vraiment très sympa à vous 2.
Bonne soirée et au plaisir.
Dan