XL 2016 supprimer caractères spéciaux

[david gom]

Bonjour je souhaite supprimer les caractères spéciaux autres que a-z sur ce fichier.

Auriez vous une solution ?

Merci à vous

 

[Staple1600]

Re, Bonjour Amilo

mapomme m'a fait replongé dans mes archives
Mais moi, je fais dans l'impur

Function Utf8ToUnicode(strText)
   With CreateObject("ADODB.Stream")
      .Open
      .Charset = "Windows-1252"
      .WriteText strText
      .Position = 0
      .Type = 2
      .Charset = "utf-8"
      Utf8ToUnicode = .ReadText(-1)
      .Close
   End With
End Function

NB: Ne fonctionne que sous Windows.

 

[patricktoulon]

re
Bonsoir Staple1600
erreur chez moi

 

[Staple1600]

Re, Bonsoir patricktoulon

Pas chez moi.
Mais de toute façon, ce n'est qu'une fonction spéciale confinement
Et personnellement, j'essaie de choisir les bons paramètres de l'assistant d'importation Texte quand j'importe un fichier Texte
(pour conserver les caractères accentués)

Et surtout la question est résolue pour le demandeur depuis quelques posts

 

[Staple1600]

Re

•>patricktoulon
Tu m'as mis le doute, alors j'ai testé sur toute la colonne A
(du fichier d'origine)
Toujours pas d'erreur

Sub Test_OK() 'XL2K13/32bits-W10/64bits
Dim i&, t, tt
t = Range("A2:A3385").Value
ReDim tt(UBound(t, 1))
For i = LBound(t, 1) To UBound(t, 1)
tt(i) = Utf8ToUnicode(CStr(t(i, 1)))
Next
[C1].Resize(UBound(tt)) = Application.Transpose(tt)
End Sub

 

[patricktoulon]

re
a la place de -1 je met 100 et j'ai plus l'erreur mais alors le résultat

 

[Staple1600]

Re

•>patricktoulon
Ça fonctionne toujours

Sub test_bis()
Dim stg, zzz, i%, Bazinga$
stg = Array("NOM1 Marie-Ségolène", "NOM2 BÉRÉNICE", "NOM3 Marie-Ségolène", "NOM4 BÉRÉNICE", "NOM5 Marie-Ségolène", "NOM6 BÉRÉNICE", "NOM7 Marie-Ségolène")
ReDim zzz(UBound(stg))
For i = LBound(stg) To UBound(stg)
zzz(i) = Utf8ToUnicode(CStr(stg(i)))
Next
Bazinga = Join(zzz, Chr(10))
MsgBox Bazinga
End Sub

NB/ Question: pourquoi tu n'es pas passé à W10 ?

 

[Staple1600]

Re

100 ??
Pour infos
-1= adReadAll

StreamReadEnum - ActiveX Data Objects (ADO)

StreamReadEnum

docs.microsoft.com

 

[patricktoulon]

re
parce que je fait parti de ceux qui décident quoi et quand un truc doit être installé, modifié ou supprimer sur mon PC
si tu crois avoir ce pouvoir sur le tiens avec W10 et bien tu es bien naïf
déjà que je pleure misère avec 2013 et 2016 sur le portable
ils sont lent, lent,lent pfiuuuuu!!!! alors W10 là je me tire une balle

pour info c'est pas stable a l'ouverture ca fonctionne 1 fois et a la relance erreur paramètre

 

[Staple1600]

Re

???
Relire mon précédent message

NB: Je ne faisais que te poser une question.
Ni plus, ni moins.

 

[patricktoulon]

re j'ai vu "-1"
mais ca marche 1 fois
pourtant je connait adobstream je m'en sert en base 64 et binaire ça fonctionne très bien

 

[Staple1600]

Re

Alors pourquoi tu as mis 100?
(d'après la doc c'est -1 ou -2, non?)
Et ça donne quoi l'essai de la macro du message#36?

 

[Staple1600]

Re

Confinement oblige, j'ai encore remis dans le nez dans mes archives.
Il restait la voie des API
(test OK sur XL2K13&W10/64bits)

Spoiler: La voici

Option Explicit
Private Declare Function MultiByteToWideChar Lib "Kernel32" _
    (ByVal CodePage As Long, ByVal dwFlags As Long, ByVal lpMultiByteStr As Long, ByVal cchMultiByte As Long, ByVal lpWideCharStr As Long, ByVal cchWideChar As Long) As Long
Private Declare Function WideCharToMultiByte Lib "Kernel32" _
    (ByVal CodePage As Long, ByVal dwFlags As Long, ByVal lpWideCharStr As Long, ByVal cchWideChar As Long, ByVal lpMultiByteStr As Long, ByVal cchMultiByte As Long, ByVal lpDefaultChar As Long, ByVal lpUsedDefaultChar As Long) As Long
Const CP_ACP = 0
Const CP_UTF8 = 65001
Public Function UTF8_Decode(ByVal Text As String) As String
Dim lLength&, sBuffer$
Text = StrConv(Text, vbFromUnicode)
lLength = MultiByteToWideChar(CP_UTF8, 0, StrPtr(Text), -1, 0, 0)
sBuffer = Space$(lLength)
lLength = MultiByteToWideChar(CP_UTF8, 0, StrPtr(Text), -1, StrPtr(sBuffer), Len(sBuffer))
UTF8_Decode = Left$(sBuffer, lLength - 1)
End Function
Sub Test_Ter()
Dim stg, zzz, i%, Bazinga$
stg = Array("NOM1 Marie-Ségolène", "NOM2 BÉRÉNICE", "NOM3 Marie-Ségolène", "NOM4 BÉRÉNICE", "NOM5 Marie-Ségolène", "NOM6 BÉRÉNICE", "NOM7 Marie-Ségolène")
ReDim zzz(UBound(stg))
For i = LBound(stg) To UBound(stg)
zzz(i) = UTF8_Decode(CStr(stg(i)))
Next
Bazinga = Join(zzz, Chr(10))
MsgBox Bazinga
End Sub

 

[Amilo]

re
Bonsoir Staple1600
erreur chez moi
Regarde la pièce jointe 1062494

Re,

Chez moi, le code à Staple du message #31 fonctionne et je n'ai pas de message d'erreur,
Par contre, en voyant la proposition à mapomme qui présente une autre logique,
je me demande si nous ne serions pas hors sujet car dans cet exemple, les caractères spéciaux sont remplacés par des caractères de l'alphabet !!!


Edit : oups en plus signalé par mapomme dans son message :

Cette fonction ne supprime pas les caractères spéciaux (ce qui à mon humble avis ne se justifie en aucun cas) mais les transforme en caractère ascii.

Cordialement

 

[Staple1600]

Re

Amilo
J'ai pu ouvrir le fichier original qui contenait des patronymes.
Les données semblaient provenir d'un import
Et le souci c'était les caractères accentués mal restranscrits
Voir exemple dans mon dernier test.
Donc mapomme était pil poil dans le cœur du sujet.
Le reste est du à ce que le confinement nous oblige à nous occuper plutôt dans VBE (que sur ma TV pour ce qui me concerne)

 

[dysorthographie]

bonsoir,
désolé mais dans ton ficher je ne vois pas de caractères spéciaux mais de l'UTF8!

Sub Test()
Debug.Print Encode_UTF8("âàèéç"), Decode_UTF8("âà èéç")
End Sub
 
 
Public Function Encode_UTF8(astr)
    Dim c
    Dim n
    Dim utftext
 
    utftext = ""
    n = 1
    Do While n <= Len(astr)
        c = AscW(Mid(astr, n, 1))
        If c < 128 Then
            utftext = utftext + Chr(c)
        ElseIf ((c >= 128) And (c < 2048)) Then
            utftext = utftext + Chr(((c \ 64) Or 192))
            utftext = utftext + Chr(((c And 63) Or 128))
        ElseIf ((c >= 2048) And (c < 65536)) Then
            utftext = utftext + Chr(((c \ 4096) Or 224))
            utftext = utftext + Chr((((c \ 64) And 63) Or 128))
            utftext = utftext + Chr(((c And 63) Or 128))
        Else ' c >= 65536
            utftext = utftext + Chr(((c \ 262144) Or 240))
            utftext = utftext + Chr(((((c \ 4096) And 63)) Or 128))
            utftext = utftext + Chr((((c \ 64) And 63) Or 128))
            utftext = utftext + Chr(((c And 63) Or 128))
        End If
        n = n + 1
    Loop
    Encode_UTF8 = utftext
End Function
Public Function Decode_UTF8(astr)
    Dim c0, c1, c2, c3
    Dim n
    Dim unitext
 
    If isUTF8(astr) = False Then
        Decode_UTF8 = astr
        Exit Function
    End If
 
    unitext = ""
    n = 1
    Do While n <= Len(astr)
        c0 = Asc(Mid(astr, n, 1))
        If n <= Len(astr) - 1 Then
            c1 = Asc(Mid(astr, n + 1, 1))
        Else
            c1 = 0
        End If
        If n <= Len(astr) - 2 Then
            c2 = Asc(Mid(astr, n + 2, 1))
        Else
            c2 = 0
        End If
        If n <= Len(astr) - 3 Then
            c3 = Asc(Mid(astr, n + 3, 1))
        Else
            c3 = 0
        End If
 
        If (c0 And 240) = 240 And (c1 And 128) = 128 And (c2 And 128) = 128 And (c3 And 128) = 128 Then
            unitext = unitext + ChrW((c0 - 240) * 65536 + (c1 - 128) * 4096) + (c2 - 128) * 64 + (c3 - 128)
            n = n + 4
        ElseIf (c0 And 224) = 224 And (c1 And 128) = 128 And (c2 And 128) = 128 Then
            unitext = unitext + ChrW((c0 - 224) * 4096 + (c1 - 128) * 64 + (c2 - 128))
            n = n + 3
        ElseIf (c0 And 192) = 192 And (c1 And 128) = 128 Then
            unitext = unitext + ChrW((c0 - 192) * 64 + (c1 - 128))
            n = n + 2
        ElseIf (c0 And 128) = 128 Then
            unitext = unitext + ChrW(c0 And 127)
            n = n + 1
        Else ' c0 < 128
            unitext = unitext + ChrW(c0)
            n = n + 1
        End If
    Loop
 
    Decode_UTF8 = unitext
End Function
Public Function isUTF8(astr)
    Dim c0, c1, c2, c3
    Dim n
 
    isUTF8 = True
    n = 1
    Do While n <= Len(astr)
        c0 = Asc(Mid(astr, n, 1))
        If n <= Len(astr) - 1 Then
            c1 = Asc(Mid(astr, n + 1, 1))
        Else
            c1 = 0
        End If
        If n <= Len(astr) - 2 Then
            c2 = Asc(Mid(astr, n + 2, 1))
        Else
            c2 = 0
        End If
        If n <= Len(astr) - 3 Then
            c3 = Asc(Mid(astr, n + 3, 1))
        Else
            c3 = 0
        End If
 
        If (c0 And 240) = 240 Then
            If (c1 And 128) = 128 And (c2 And 128) = 128 And (c3 And 128) = 128 Then
                n = n + 4
            Else
                isUTF8 = False
                Exit Function
            End If
        ElseIf (c0 And 224) = 224 Then
            If (c1 And 128) = 128 And (c2 And 128) = 128 Then
                n = n + 3
            Else
                isUTF8 = False
                Exit Function
            End If
        ElseIf (c0 And 192) = 192 Then
            If (c1 And 128) = 128 Then
                n = n + 2
            Else
                isUTF8 = False
                Exit Function
            End If
        ElseIf (c0 And 128) = 0 Then
            n = n + 1
        Else
            isUTF8 = False
            Exit Function
        End If
    Loop
End Function