Macro qui convertit un fichier Excel en CSV UTF-8
Bonjour, j'ai plusieurs macros VBA, je veux principalement convertir un fichier Excel en un fichier CSV encodé UTF-8 sans nomenclature
Sub Main()
Dim fileToConvertInCSV As String
Dim fileToConvertInUTF8 As String
fileToConvertInCSV = FileSelected
fileToConvertInUTF8 = CSVConverted(fileToConvertInCSV)
Call WriteANSItoUF8WithoutBOM(fileToConvertInUTF8, fileToConvertInUTF8)
'améliorations à implémenter
'File Selected => n'autoriser que la sélection Excel
'ConvertUTF8 => convertir en UTF8 sans N
End Sub
Function FileSelected() As String
'Function to Open a file
Dim fd As Office.FileDialog
Set fd = Application.FileDialog(msoFileDialogFilePicker)
With fd
.Filters.Clear
'.Filters.Add "Excel Files", "*.xlsx?", 1
.Title = "Choose an Excel file"
.AllowMultiSelect = False
If .Show = True Then
FileSelected = .SelectedItems(1)
End If
End With
End Function
Function CSVConverted(fileToConvert As String) As String
Dim toConvertFile As String
Dim convertedFile As String
Dim Rows As Long
Dim Cols As Long
Dim J As Long
Dim K As Long
Dim sTemp As String
Dim sSep As String
Dim wb As Workbook
Const adCrLf As Long = -1
Const adModeUnknown As Long = 0
Const adSaveCreateOverWrite As Long = 2
Const adTypeText As Long = 2
sSep = ";!@#;" 'Specify the separator to be used
toConvertFile = fileToConvert
Workbooks.Open toConvertFile
Sheets(1).Activate
Dim fileExtension As String
fileExtension = Right(toConvertFile, Len(toConvertFile) - InStrRev(toConvertFile, "."))
If fileExtension = "xlsm" Or fileExtension = "xlsx" Or fileExtension = ".xlsb" Or fileExtension = ".xls" Then
toConvertFile = Mid(toConvertFile, 1, Len(toConvertFile) - Len(fileExtension))
convertedFile = toConvertFile & ".csv"
Open convertedFile For Output As 1
With ActiveSheet
'Number of rows to export is based on the contents
'of column J. If it should be based on a different
'column, change the following line to reflect the
'column desired.
Rows = .Cells(.Rows.Count, "J").End(xlUp).Row
For J = 1 To Rows
sTemp = ""
Cols = .Cells(J, .Columns.Count).End(xlToLeft).Column
For K = 1 To Cols
sTemp = sTemp & .Cells(J, K).Value
If K < Cols Then sTemp = sTemp & sSep
Next
Print #1, sTemp
Next J
End With
Close 1
sTemp = "There were " & Rows & " rows of data written "
sTemp = sTemp & "to this file:" & vbCrLf & toConvertFile
Else
sTemp = "This macro needs to be run on a workbook "
sTemp = sTemp & "stored in the XLSX, XLSM, XLSB or XLS format."
End If
ActiveWorkbook.Close
'Dim wbName As String
'wbName = Right(toConvertFile, Len(toConvertFile) - InStrRev(toConvertFile, "\"))
'For Each wb In Workbooks
' If wb.Name = wbName Then
' Workbooks.Close wbName
' Exit Sub
' End If
'Next
MsgBox sTemp
CSVConverted = convertedFile
End Function
Ces macros permettent de convertir en fichier CSV, mais ensuite il faut encoder en UTF-8, il y a deux macros
Sub ConvertUTF8(fileToConvert, fileToSave As String)
Dim fileToConvertPath, fileToSavePath As String
fileToConvertPath = fileToConvert
fileToSavePath = fileToSave
Set UTFStream = CreateObject("ADODB.Stream"): 'Create Stream object
UTFStream.Type = 2: 'Specify stream type – we want To save text/string data.
UTFStream.Charset = "utf-8": 'Specify charset For the source text data.
UTFStream.Open: 'Open the stream
UTFStream.LoadFromFile fileToConvertPath: 'And write the file to the object stream
UTFStream.SaveToFile fileToSavePath, 2: 'Save the data to the named path
'skip BOM
UTFStream.Position = 3
'copy UTFStream to BinaryStream
Set BinaryStream = CreateObject("adodb.stream")
BinaryStream.Type = adTypeBinary
BinaryStream.Mode = adModeReadWrite
BinaryStream.Open
'Strips BOM (first 3 bytes)
UTFStream.CopyTo BinaryStream
UTFStream.Flush
UTFStream.Close
'save to file
BinaryStream.SaveToFile FName, adSaveCreateOverWrite
BinaryStream.Flush
BinaryStream.Close
Cette macro là retourne UTF_8 avec nomenclature (mais je ne veux pas ça)
Sub WriteANSItoUF8WithoutBOM(fileToConvert, fileToSave As String)
Dim fileToConvertPath, fileToSavePath As String
fileToConvertPath = fileToConvert
fileToSavePath = fileToSave
Set UTFStream = CreateObject("adodb.stream")
Set ANSIStream = CreateObject("adodb.stream")
Set BinaryStream = CreateObject("adodb.stream")
ANSIStream.Type = adTypeText
ANSIStream.Mode = adModeReadWrite
ANSIStream.Charset = "iso-8859-1"
ANSIStream.Open
ANSIStream.LoadFromFile fileToConvertPath 'ANSI File
UTFStream.Type = adTypeText
UTFStream.Mode = adModeReadWrite
UTFStream.Charset = "UTF-8"
UTFStream.Open
ANSIStream.CopyTo UTFStream
UTFStream.Position = 3 'skip BOM
BinaryStream.Type = adTypeBinary
BinaryStream.Mode = adModeReadWrite
BinaryStream.Open
'Strips BOM (first 3 bytes)
UTFStream.CopyTo BinaryStream
BinaryStream.SaveToFile fileToSavePath, adSaveCreateOverWrite
BinaryStream.Flush
BinaryStream.Close
End Sub
Et celle là me retourne un fichier ANSI
je ne vois pas comment faire UTF 8 simple, merci d'avance de votre aide
En tout cas c'est sur les 2 derniers codes de conversion UTF 8 que ça bug
Le premier me retourne un UTF 8 avec nomenclature mais les accents ne sont pas pris en compte et remplacés par des caractères moches
Le deuxieme me retourne un ANSI alors que pourtant j'ai demandé UTF 8
Je suis vraiment perdu, de prime abord je dirais que le deuxième est meilleur mais quel est le probleme, pourquoi ça ne marche pas ?
Bonjour
L'enregistrement de CSV en UTF8 existe, depuis la version 2010 il me semble.
Donc je ne comprends pas à quoi sert tout ce code
Le but c'est surtout d'automatiser le plus possible ce genre d'action avec par exemple un bouton
RE
Oui une ligne suffit...
ActiveWorkbook.SaveAs Filename:= _
"Chemin\Nom.csv", _
FileFormat:=xlCSVUTF8, CreateBackup:=False
J'ai trouvé ! Il fallait juste activer Microsoft ActiveX Data Objects dans les références :)