0

For the work, I have to create a macro in Excel who select an Excel file and transform this File into CSV in UTF-8 encoding but I meet some problems.

First of all, this is my macro who select the file

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

The macro who convert in CSV

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

But after this macro, my file is not in UTF-8, I made 2 macros for that but it doesn't work.

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
    

End Sub

This macro make an UTF-8 encoding but with BOM and in the file, the special characters are replaced

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

And this macro create stays in ANSI encoding, I don't see the problem in this macro, just it's in ANSI.

Please can you can help, i'm lost

  • Does this answer your question? [Export sheet as UTF-8 CSV file (using Excel-VBA)](https://stackoverflow.com/questions/12688311/export-sheet-as-utf-8-csv-file-using-excel-vba) – braX Nov 25 '21 at 08:41
  • 1
    Excel can save workbook as UTF-8 CSV in the first place, have you tried that? [example](https://stackoverflow.com/questions/40903525/convert-excel-xls-to-csv-with-utf-8-using-vba) – Raymond Wu Nov 25 '21 at 08:42
  • @RaymondWu it' doesn't work the code – Nicolas63 Nov 25 '21 at 09:10
  • 1
    @Nicolas63 Perhaps you can edit your question, include your code attempt based on the answer(s) (Have you tried braX's link as well?) and explain *how does it not work*? Just *doesn't work* is not helpful because there is no details and we can't help you without details. – Raymond Wu Nov 25 '21 at 09:13
  • @RaymondWu I made this (i answer in post) – Nicolas63 Nov 25 '21 at 09:35
  • @Nicolas63 Then my question to you is - Excel already has the capability to save workbook as CSV so why are you trying to make your own? Also please delete your answer as you should edit your question and include the code there. – Raymond Wu Nov 25 '21 at 09:37

0 Answers0