Encodage import de donnée depuis CSV

**Unfam0us** · 25/10/2018, 13h25

Hello à tous,

J'ai un problème avec une macro, notre stagiaire en charge de ce VBA n'est plus venu travailler du jour au lendemain. N'ayant personne en interne maitrisant le VBA je m'en donc remet à vous.

Tout fonctionne (import des données, export dans d'autres fichiers CSV mis en forme) hormis une chose, l'encodage des caractères est faux et les caractères accentués ne sont pas importés correctement. Il faut changer quelque chose dans l'import à mon avis.

Est-ce qu'un pro arriverait à me régler ça? Je lui en serait très reconnaissant

Voici le code en charge de l'import des données:

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
 
Sub ListerFichiers()
 
    Dim Rep As String, Fichier As String
    Dim suffix As String
    Dim RepExport As String
    Dim WS As Worksheet
 
    Dim nbCSV As Integer: nbCSV = 2
    Dim Ligne As String
    Dim LeTableau()
    Dim TableauFin()
    Dim i As Long: i = 0
    Dim n As Long: n = 0
    Dim j As Long
    Dim NoCol As Long
     Dim iTemp As Long: iTemp = 0
 
    'Définir le chemin du dossier source ***************************
    'Définir le chemin du dossier ou se trouve le fichier en cours**
    Rep = ThisWorkbook.Path
    'Pointer sur le chemin du dossier ou se trouve les fichiers csv*
    Rep = Rep & "\Source\"
    'Mettre les noms des CSV dans une variable *********************
    Fichier = Dir(Rep)
 
    suffix = Left(Fichier, InStr(Fichier, "-") - 1)
    Application.ScreenUpdating = False
 
    For Each WS In Worksheets
        n = n + 1
        If WS.Name <> "Sources" Then
            WS.Name = suffix
            If WS.Name = suffix Then
            On Error Resume Next
            On Error GoTo 0
                WS.[_CodeName] = suffix
            End If
 
        End If
    Next WS
    n = 0
    'MsgBox suffix
    'Boucle pour lister les fichiers csv dans la feuille Source*****
    Fichier = Rep & Fichier
    Sources.Range("A" & nbCSV).Value = Fichier
 
    '**********Importer chaque fichier CSV dans Source ***********
    Open Fichier For Input As #1
    While Not EOF(1)
        Input #1, Ligne
        i = i + 1
        ReDim Preserve LeTableau(i)
        LeTableau(i) = Split(Ligne, ";")
    Wend
    '**********Transcrire le contenu dans la feuille Excel***********
    Sheets(suffix).Activate
    Sheets(suffix).Range("B2").Value = UCase(suffix)
    For j = 1 To i - 1 'Pour chaque ligne
         For NoCol = 0 To 4 'Pour chaque colonne
              ActiveSheet.Cells(j + 5, NoCol + 1).Value = LeTableau(j + 1)(NoCol)
         Next
        '**********Encadrer les cellules et mettre en rouge le texte *****
        ActiveSheet.Range("A" & j + 5 & ":B" & j + 5).Select
        encadrerCellules 'Encadrer les cellules
 
        '**********Mettre en rouge le texte *****
        ActiveSheet.Range("C" & j + 5).Select
        ActiveSheet.Range("C" & j + 5).Font.Color = vbRed 'Mettre en rouge le texte
        encadrerCellules
        ActiveSheet.Range("D" & j + 5).Select
        ActiveSheet.Range("D" & j + 5).Font.Color = vbRed
        encadrerCellules
        ActiveSheet.Range("E" & j + 5).Select
        ActiveSheet.Range("E" & j + 5).Font.Color = vbRed
        encadrerCellules
        ActiveSheet.Range("F" & j + 5).Select
        ActiveSheet.Range("F" & j + 5).Font.Color = vbRed
        encadrerCellules
 
    Next
    Close #1
 
    RepExport = ActiveWorkbook.Path & "\Final\"
    ActiveSheet.Copy
    ActiveWorkbook.SaveAs Filename:=RepExport & _
    suffix & "-UserAccounts.xlsx"
    ActiveWorkbook.Close True
 
    Fichier = Dir
'    nbCSV = nbCSV + 1
    Application.ScreenUpdating = True
    'MsgBox "Exportation terminé"
End Sub

**Igloobel** · 25/10/2018, 13h36

Bonjour,

Que se passe-t-il lorsque l'on ouvre directement le fichier csv ?

Les fichier .CSV sont bien des fichiers texte mais ils sont ouvrable directement dans Excel d'ou ma question

tu dis

A bientôt

**Unfam0us** · 25/10/2018, 13h41

Hello, merci pour ta réponse super rapide.

Alors oui je peux sans autre ouvrir le fichier CSV avec Excel et l'encodage est correct. Il s'agit d'extractions réalisées en Powershell.

Invité · 25/10/2018, 15h04

https://www.developpez.net/forums/d1...a/#post8212249

**Unfam0us** · 25/10/2018, 15h24

Envoyé par dysorthographie

https://www.developpez.net/forums/d1...a/#post8212249

Merci pour le lien, par contre mon niveau de VBA ne me permet pas de savoir quoi faire de cela dans toutes les macros du traitement que j'ai. J'espérais un truc assez simple dans le bout de code que j'ai donné, style .encoding utf8 ou je ne sais quoi

Invité · 25/10/2018, 16h10

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
  Const DATAOBJECT_BINDING As String = "new:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}"
Sub ListerFichiers()
Dim cn As Object: Set cn = CreateObject("Adodb.Connection")
 With cn
    .Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=C:\MyRep;Extended Properties=""Text;HDRYES;FMT=Delimited;"""
    t = TableToutes(cn)
    For i = 0 To UBound(t)
        ShemaIn "C:\MyRep\", Replace(t(i), "#", "."), "Delimited(;)"
        Set Rs = .Execute("select * from " & t(i))
        If Not Rs.EOF Then
            PressePapier = Decode_UTF8(Rs.GetString(, , vbTab, vbCrLf)) 'Decode_UTF8 converti UTF8 en ISO pas utile si déjà ISO!
            Cells(Cells.Rows.Count, "A").End(xlUp).Offset(1).PasteSpecial xlPasteAll
      End If
    Next
    .Close
 End With
End Sub
 
 
 
 
Public Property Get TableToutes(Connexion As Object)
Dim t() As String, i As Integer
TableToutes = False
With Connexion.OpenSchema(20)
    While Not .EOF
        ReDim Preserve t(i)
        t(i) = !TABLE_NAME
        i = i + 1
        .MoveNext
    Wend
    .Close
    TableToutes = t
End With
End Property
Public Property Let PressePapier(Value)
    With CreateObject(DATAOBJECT_BINDING)
        .SetText Value
        .PutInClipboard
    End With
End Property
Public Property Get PressePapier()
    With CreateObject(DATAOBJECT_BINDING)
        .GetFromClipboard
        PressePapier = .GetText
    End With
End Property
Sub main()
    Debug.Print Encode_UTF8("?")
    Debug.Print Decode_UTF8(Encode_UTF8("?"))
    Debug.Print Decode_UTF8("éa")
    Debug.Print isUTF8("éa")
    Debug.Print isUTF8("abcde")
    Debug.Print Encode_UTF8("abcdeééàê")
    Debug.Print Decode_UTF8(Encode_UTF8("abcdeééàê"))
End Sub
'   Char. number range  |        UTF-8 octet sequence
'      (hexadecimal)    |              (binary)
' --------------------+---------------------------------------------
'   0000 0000-0000 007F | 0xxxxxxx
'   0000 0080-0000 07FF | 110xxxxx 10xxxxxx
'   0000 0800-0000 FFFF | 1110xxxx 10xxxxxx 10xxxxxx
'   0001 0000-0010 FFFF | 11110xxx 10xxxxxx 10xxxxxx 10xxxxxx
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
 
'   Char. number range  |        UTF-8 octet sequence
'      (hexadecimal)    |              (binary)
' --------------------+---------------------------------------------
'   0000 0000-0000 007F | 0xxxxxxx
'   0000 0080-0000 07FF | 110xxxxx 10xxxxxx
'   0000 0800-0000 FFFF | 1110xxxx 10xxxxxx 10xxxxxx
'   0001 0000-0010 FFFF | 11110xxx 10xxxxxx 10xxxxxx 10xxxxxx
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
 
'   Char. number range  |        UTF-8 octet sequence
'      (hexadecimal)    |              (binary)
' --------------------+---------------------------------------------
'   0000 0000-0000 007F | 0xxxxxxx
'   0000 0080-0000 07FF | 110xxxxx 10xxxxxx
'   0000 0800-0000 FFFF | 1110xxxx 10xxxxxx 10xxxxxx
'   0001 0000-0010 FFFF | 11110xxx 10xxxxxx 10xxxxxx 10xxxxxx
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
Public Sub ShemaIn(Server As String, fichier As String, Delimited As String)
Dim txt As String
txt = "[" & fichier & "]" & vbCrLf & "Format= " & Delimited
Dim fso, NewFichier
Set fso = CreateObject("Scripting.FileSystemObject")
Set NewFichier = fso.OpenTextFile(Server & "\schema.ini", 2, True)
NewFichier.Write txt
NewFichier.Close
Set NewFichier = Nothing
Set fso = Nothing
End Sub

**Unfam0us** · 25/10/2018, 17h17

Désolé mais un code VBA de 221 lignes sans commentaires (ni ici ni dans le code) alors que je n'utilise jamais ce langage je ne sais pas quoi en faire (et je n'exécute pas des macro que je ne comprends pas un minimum).
Je ne veux pas être ingrat, je suis content d'avoir des réponses mais du code dans la tronche je ne peux rien en faire. Ne communiques-tu qu'en VBA sur les forums?

Invité · 25/10/2018, 17h37

Bonsoir,
Pas de problème.

Je fais souvent comme ça pour voir si ce que je propose suscite un quelconque intérêt. Quand les choses ce complique je distille mes explications au mérite.

Ne communiques-tu qu'en VBA sur les forums?

En fait je communique de moins en moins, il faut que le sujet m'intéresse si non je n'y répond même pas.

Sur les 221 ligne de code 200 au moins convertissent les caractères UTF8 en ISO et inversement. Pas grand choses à comprendre.

Ce n'est que de la conversion de code ASCII

Char. number range (hexadecimal)	UTF-8 octet sequence (binary)
0000 0000-0000 007F	0xxxxxxx
0000 0080-0000 07FF	110xxxxx 10xxxxxx
0000 0800-0000 FFFF	1110xxxx 10xxxxxx 10xxxxxx
0001 0000-0010 FFFF	11110xxx 10xxxxxx 10xxxxxx 10xxxxxx

https://www.developpez.net/forums/d1...e/#post8606020

Je comprend la confiance n'est pas à l'ordre du jour !

**Unfam0us** · 26/10/2018, 09h20

Merci pour ton temps, mon problème est résolu.

Encodage import de donnée depuis CSV

Macros et VBA Excel

Vue hybride

Discussions similaires

Partager

Partager