Convertir plusieurs fichiers CSV UTF 8 en fichiers XLSX

Const sExtension As String = "csv"
Const sNewExtension As String = "xlsx"
Const TypeFichier = "csv"

Dim sDossier As String
Dim FSO As Object
Dim Dossier As Object
Dim sFichier As String, F As String
Dim Pos As Long, i As Long, sExt As String
Dim TFichier() As String
Dim sNom As String

sDossier = ThisWorkbook.Path

    Application.ScreenUpdating = False
    Set FSO = CreateObject("Scripting.FileSystemObject")
    Set Dossier = FSO.GetFolder(sDossier)

    TFichier = Split(TypeFichier, ";")

    sFichier = Dir$(sDossier & "\*.*")

    Do While Len(sFichier) > 0
        F = FSO.GetFileName(sFichier)
        For i = LBound(TFichier) To UBound(TFichier)
            If UCase(sFichier) <> UCase(ThisWorkbook.Name) Then
                Pos = InStr(F, TFichier(i))
                sExt = FSO.GetExtensionName(F)
                If Pos > 0 And UCase(sExt) = UCase(sExtension) Then
                    sNom = Left$(F, Len(F) - Len(sExt))

                    Workbooks.Open Filename:=sDossier & "\" & sFichier, local:=True
                    Application.DisplayAlerts = False
                    ActiveWorkbook.SaveAs Filename:=sDossier & "\" & sNom & "xlsx", FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
                    ActiveWorkbook.Close
                    Application.DisplayAlerts = True

                    Nb = Nb + 1
                End If
            End If
        Next i
        sFichier = Dir$()
        Application.StatusBar = Nb
    Loop

   ' If bSousDossier Then
    '    For Each Dossier In Dossier.SubFolders
     '       ChangerExtensionFichiers Dossier.Path, True
      '  Next Dossier
    'End If

    Application.ScreenUpdating = True
    Set Dossier = Nothing
    Set FSO = Nothing
End Sub

Bonjour

Le plus simple est de passer par PowerQuery intégré à Excel avec éventuellement quelques lignes de VBA pour délier le résultat de la source

Tony74 a écrit :

J'ai besoin de votre aide pour convertir tous les fichiers CSV avec séparateur pont-virgule et encodage UTF 8 vers le format XLSX.

Bonjour Tony, bonjour Chris,

as-tu un exemple de fichier csv en utf-8 ? tout n'est pas codé de façon toujours aussi pure qu'on le croit ...

Hello,

Oui j'ai des exemple mais là je suis sûr que c'est de l'UTF8 car j'ai fait des tests. (Les caractères accentués ne passent pas par exemple)

Pour la solution de Power Query ça me semble bien pour rassembler les données dans un même fichier Excel. Par contre dans mon cas je n'ai pas trouvé comment faire car les fichiers n'ont pas toujours le même nom ni le même nombre de colonnes.

Et il faut bien que chaque fichier soit transformé en fichier Excel.

Est-il possible de combiner VBA et Power Query?

Proposition (non testée car pas de fichier utf8)

Option Explicit
Sub importer()
Dim chemin$, Rep As FileDialog

    ' choix du répertoire
    Set Rep = Application.FileDialog(msoFileDialogFolderPicker)
    Application.FileDialog(msoFileDialogFolderPicker).Title = "Choix du répertoire des fichiers ..."
    Rep.Show
    If Rep.SelectedItems.Count = 0 Then Exit Sub
    chemin = Rep.SelectedItems(1) & "\"

    ' effacement et préparation
    Cells.Clear
    Range("A1").Select

    '         chemin, separateur (; par défaut), debut (1 par défaut), entetes (True par défaut)
    importCSV chemin

End Sub

Sub importCSV(chemin As String, Optional sep As String = ";", Optional debut As Integer = 1, Optional entetes As Boolean = True)
' sep est le séparateur , ou ; ou vbTab
' debut caractérise la première ligne du fichier csv à importer
' entetes indique s'il faut importer les en-têtes se trouvant sur la ligne début

Dim fichier$, T() As String, D, ligne&, i%, ContenuLigne$, nItems%

fichier = Dir(chemin & "*.csv")
Do While fichier <> ""
    Open chemin & fichier For Input As #1
        ligne = 1
        Do While Not EOF(1)
            Line Input #1, ContenuLigne
            T = Split(ContenuLigne, sep)
            nItems = UBound(T) + 1
            If ligne >= debut Then
                If ligne = debut Then ReDim D(1 To nItems, 1 To 1)
                If ligne > debut Then ReDim Preserve D(1 To nItems, 1 To ligne - debut + 1) ' Preserve ne permet de redimensionner que la dernière dimension d'un tableau avec conservation des données
                For i = 0 To UBound(T)
                    ' si date : effectuer permutation jour et mois
                    D(i + 1, ligne - debut + 1) = Utf8_Decode(T(i))
                Next i
            End If
            ligne = ligne + 1
        Loop
    Close #1
    D = Application.Transpose(D)
    If ligne - debut = 1 Then
        Selection.Resize(1, UBound(D)) = D ' cas d'une seule ligne dans le fichier csv
    Else
        Selection.Resize(UBound(D), UBound(D, 2)) = D
    End If
    Range("A" & Rows.Count).End(xlUp).Offset(1, 0).Select
    fichier = Dir
    If entetes Then entetes = False: debut = debut + 1  ' on passe l'en-tête pour les fichiers suivants
Loop

End Sub

Function Utf8_Decode(ByVal txt As String) As String
Dim ln As Long, s As String, i As Integer, j As Integer, K As Integer
    For ln = 1 To Len(txt)
        i = Asc(Mid(txt, ln, 1))
        If i > 127 Then
            If Not i And 32 Then
            j = Asc(Mid(txt, ln + 1, 1))
            s = s & ChrW$(((31 And i) * 64 + (63 And j)))
            ln = ln + 1
        Else
            j = Asc(Mid(txt, ln + 1, 1))
            K = Asc(Mid(txt, ln + 2, 1))
            s = s & ChrW$(((i And 15) * 16 * 256) + ((j And 63) * 64) + (K And 63))
            ln = ln + 2
        End If
            Else
            s = s & Chr$(i)
        End If
    Next ln
    Utf8_Decode = s
End Function

Tony74 a écrit :

Est-il possible de combiner VBA et Power Query?

Oui, sur 2016 le modèle objet PQ est dispo

@Tony .... je viens de tester ma macro, c'est ok, mais il s'agit de compiler à la queue leu leu les fichiers.

Tu peux t'inspirer de la macro et de la fonction de décodage pour modifier ta macro qui enregistre chaque csv indépendamment !

Ou bien poursuis avec PowerQ (bonjour Chris)

Merci @Steelson je vais tester de suite ^^

Et merci @78Chris, je suis curieux de voir des exemples d'utilisation

Je vous tiens au courant

Tony74 a écrit :

@78Chris, je suis curieux de voir des exemples d'utilisation

Bonjour

Peux-tu joindre 2 fichiers exemples, de structure différentes pour modéliser

78chris a écrit :

Tony74 a écrit :

Peux-tu joindre 2 fichiers exemples, de structure différentes pour modéliser

@Chris ... je me suis fait 2 fichiers blindés de caractères diacritiques latin. La structure est différente.

Une solution VBA

Option Explicit
Const sep = ";"

Sub csv2xlsx()
Dim chemin$, Rep As FileDialog

    ' choix du répertoire
    Set Rep = Application.FileDialog(msoFileDialogFolderPicker)
    Application.FileDialog(msoFileDialogFolderPicker).Title = "Choix du répertoire des fichiers ..."
    Rep.Show
    If Rep.SelectedItems.Count = 0 Then Exit Sub
    chemin = Rep.SelectedItems(1) & "\"

    importCSV chemin

End Sub

Sub importCSV(chemin As String)
' sep est le séparateur , ou ; ou vbTab
' debut caractérise la première ligne du fichier csv à importer
' entetes indique s'il faut importer les en-têtes se trouvant sur la ligne début
Dim wb As Workbook, ws As Worksheet
Dim fichier$, T() As String, D, ligne&, i%, ContenuLigne$, nItems%, ff

fichier = Dir(chemin & "*.csv")
Do While fichier <> ""
    ff = FreeFile
    Open chemin & fichier For Input As #ff
        ligne = 0
        Do While Not EOF(1)
            ligne = ligne + 1
            Line Input #ff, ContenuLigne
            T = Split(ContenuLigne, sep)
            nItems = UBound(T) + 1
            If ligne = 1 Then ReDim D(1 To nItems, 1 To 1)
            If ligne > 1 Then ReDim Preserve D(1 To nItems, 1 To ligne)  ' Preserve ne permet de redimensionner que la dernière dimension d'un tableau avec conservation des données
            For i = 0 To UBound(T)
                D(i + 1, ligne) = Utf8_Decode(T(i))
            Next i
        Loop
    Close #ff
    D = Application.Transpose(D)
    Set wb = Workbooks.Add  ' On ajoute un classeur
    Set ws = wb.Worksheets(1)  ' On crée l'objet onglet dans le nouveau classeur créé
    If ligne = 1 Then
        ws.Cells(1, 1).Resize(1, UBound(D)) = D ' cas d'une seule ligne dans le fichier csv
    Else
        ws.Cells(1, 1).Resize(UBound(D), UBound(D, 2)) = D
    End If
    wb.SaveAs chemin & Replace(fichier, ".csv", ".xlsx")
    wb.Close

fichier = Dir
Loop

End Sub

Function Utf8_Decode(ByVal txt As String) As String
Dim ln As Long, s As String, i As Integer, j As Integer, K As Integer
    For ln = 1 To Len(txt)
        i = Asc(Mid(txt, ln, 1))
        If i > 127 Then
            If Not i And 32 Then
            j = Asc(Mid(txt, ln + 1, 1))
            s = s & ChrW$(((31 And i) * 64 + (63 And j)))
            ln = ln + 1
        Else
            j = Asc(Mid(txt, ln + 1, 1))
            K = Asc(Mid(txt, ln + 2, 1))
            s = s & ChrW$(((i And 15) * 16 * 256) + ((j And 63) * 64) + (K And 63))
            ln = ln + 2
        End If
            Else
            s = s & Chr$(i)
        End If
    Next ln
    Utf8_Decode = s
End Function

RE

J'ai modélisé sur les 2 fichiers de Steelson mais ne sachant pas quels sont les paramètres régionaux des véritables fichiers, j'attends les vrais exemples car cela n'est pas neutre pour les dates et les nombres

Il peut y avoir aussi (dans les fichiers attendus) des informations de tête qui ne recoupent pas toutes les colonnes. Dans mon cas, le "tableau" est carré avec le même nombre d'informations sur toutes les lignes. Cela ne conviendra pas si ce n'est pas le cas !

Bonjour,
Désolé pour l'attente je n'ai pas encore réussi mais je continue à essayer.
Voici les 2 fichiers que j'aimerai traduire. Il y en a un pour lequel il n'y a pas de caractères spéciaux (libelle) donc ça passe par contre pour l'autre ça ne passe pas.
Je n'arrive pas importer les fichiers avec le fichier reçu.
Le but est de les importer les traduire en UTF8 et les enregistrer en XLSX au même endroit.
Par rapport à mon code, les manipulation semblent différentes mais j'ai du mal à intégrer seulement la procédure ou la fonction qui va bien.
Est-ce que vous pouvez m'aider svp?

Bonjour

Une ligne par fichier, c'est assez léger pour tester...

Cela fonctionne avec PowerQuery + VBA mais, comme on ne connait ni les noms ni le type des colonnes, cela met tout comme texte

On pourrait éventuellement chercher les nombres sur la 1ère ligne mais si elle n'est pas représentative...

Tony74 a écrit :

Voici les 2 fichiers que j'aimerai traduire. Il y en a un pour lequel il n'y a pas de caractères spéciaux (libelle) donc ça passe par contre pour l'autre ça ne passe pas.
Je n'arrive pas importer les fichiers avec le fichier reçu.

Ah bon, j vais essayer de mon côté avec la solution proposée.

J'ai traduis correctement les 2 en terme de caractères, il reste un petit réglage à faire car tout se trouve sur la même ligne (curieux pour un fichier csv)

Bonjour,

Merci pour votre aide par contre je suis navré j'ai essayé le code de @Steelson et j'ai une incompatibilité de type sur la ligne ci-dessous:

D = Application.Transpose(D)
Est-ce qu'il faut mettre un autre type que "String" svp.

J'ai essayé de trouver une parade mais avec PowerQuery et VBA mais vu que les colonnes peuvent être variable au niveau du nombre et que je suis pas très à l'aise, j'ai pas l'impression que je peux m'en sortir.

C'est que probablement tu ne dois avoir qu'une seule ligne...

et du reste, cela me semble être dû au fichier pour lequel je n'arrive pas à détecter la fin de ligne.

Essaie cette solution qui traite ligne par ligne et non plus globalement le fichier.

Option Explicit
Const sep = ";"

Sub csv2xlsx()
Dim chemin$, Rep As FileDialog

    ' choix du répertoire
    Set Rep = Application.FileDialog(msoFileDialogFolderPicker)
    Application.FileDialog(msoFileDialogFolderPicker).Title = "Choix du répertoire des fichiers ..."
    Rep.Show
    If Rep.SelectedItems.Count = 0 Then Exit Sub
    chemin = Rep.SelectedItems(1) & "\"

    importCSV chemin

End Sub

Sub importCSV(chemin As String)
Dim wb As Workbook, ws As Worksheet
Dim fichier$, T() As String, D, ligne&, i%, ContenuLigne$, nItems%, ff

fichier = Dir(chemin & "*.csv")
Do While fichier <> ""

    Set wb = Workbooks.Add
    Set ws = wb.Worksheets(1)

    ff = FreeFile
    Open chemin & fichier For Input As #ff
        ligne = 0
        Do While Not EOF(1)
            ligne = ligne + 1
            Line Input #ff, ContenuLigne
            T = Split(Utf8_Decode(ContenuLigne) & sep, sep)
            ws.Cells(ligne, 1).Resize(1, UBound(T)) = T
        Loop
    Close #ff

    wb.SaveAs chemin & Replace(fichier, ".csv", ".xlsx")
    wb.Close

fichier = Dir
Loop

End Sub

Function Utf8_Decode(ByVal txt As String) As String
Dim ln As Long, s As String, i As Integer, j As Integer, K As Integer
    For ln = 1 To Len(txt)
        i = Asc(Mid(txt, ln, 1))
        If i > 127 Then
            If Not i And 32 Then
            j = Asc(Mid(txt, ln + 1, 1))
            s = s & ChrW$(((31 And i) * 64 + (63 And j)))
            ln = ln + 1
        Else
            j = Asc(Mid(txt, ln + 1, 1))
            K = Asc(Mid(txt, ln + 2, 1))
            s = s & ChrW$(((i And 15) * 16 * 256) + ((j And 63) * 64) + (K And 63))
            ln = ln + 2
        End If
            Else
            s = s & Chr$(i)
        End If
    Next ln
    Utf8_Decode = s
End Function