Export sheet as UTF-8 CSV file (using Excel-VBA)

Question

I would like to export a file I have created in UTF-8 CSV using VBA. From searching message boards, I have found the following code that converts a file to UTF-8 (from this thread):

Sub SaveAsUTF8() 

    Dim fsT, tFileToOpen, tFileToSave As String 

    tFileToOpen = InputBox("Enter the name and location of the file to convert" & vbCrLf & "With full path and filename ie. C:\MyFolder\ConvertMe.Txt") 
    tFileToSave = InputBox("Enter the name and location of the file to save" & vbCrLf & "With full path and filename ie. C:\MyFolder\SavedAsUTF8.Txt") 

    tFileToOpenPath = tFileToOpen 
    tFileToSavePath = tFileToSave 

Set fsT = CreateObject("ADODB.Stream"): 'Create Stream object
fsT.Type = 2: 'Specify stream type – we want To save text/string data.
fsT.Charset = "utf-8": 'Specify charset For the source text data.

fsT.Open: 'Open the stream
fsT.LoadFromFile tFileToOpenPath: 'And write the file to the object stream

fsT.SaveToFile tFileToSavePath, 2: 'Save the data to the named path

End Sub 

However, this code only converts a non-UTF-8 file to UTF-8. If I were to save my file in non-UTF-8 and then convert it to UTF-8, it would have already lost all the special characters it contained, thus rendering the process pointless!

What I'm looking to do is save an open file in UTF-8 (CSV). Is there any way of doing this with VBA?

n.b. I have also asked this question on the 'ozgrid' forum. Will close both threads together if I find a solution.

Answer 1

Finally in Office 2016, you can simply savs as CSV in UTF8.

Sub SaveWorkSheetAsCSV()

Dim wbNew As Excel.Workbook
Dim wsSource As Excel.Worksheet, wsTemp As Excel.Worksheet
Dim name As String



    Set wsSource = ThisWorkbook.Worksheets(1)
    name = "test"
    Application.DisplayAlerts = False 'will overwrite existing files without asking
    Set wsTemp = ThisWorkbook.Worksheets(1)
    Set wbNew = ActiveWorkbook
    Set wsTemp = wbNew.Worksheets(1)
    wbNew.SaveAs name & ".csv", xlCSVUTF8 'new way
    wbNew.Close
    Application.DisplayAlerts = True

End Sub

This will save the worksheet 1 into csv named test.

Answer 2

Here's my solution based on Excel VBA - export to UTF-8, which user3357963 linked to earlier. It includes macros for exporting a range and a selection.

Option Explicit

Const strDelimiter = """"
Const strDelimiterEscaped = strDelimiter & strDelimiter
Const strSeparator = ","
Const strRowEnd = vbCrLf
Const strCharset = "utf-8"

Function CsvFormatString(strRaw As String) As String

    Dim boolNeedsDelimiting As Boolean

    boolNeedsDelimiting = InStr(1, strRaw, strDelimiter) > 0 _
        Or InStr(1, strRaw, Chr(10)) > 0 _
        Or InStr(1, strRaw, strSeparator) > 0

    CsvFormatString = strRaw

    If boolNeedsDelimiting Then
        CsvFormatString = strDelimiter & _
            Replace(strRaw, strDelimiter, strDelimiterEscaped) & _
            strDelimiter
    End If

End Function

Function CsvFormatRow(rngRow As Range) As String

    Dim arrCsvRow() As String
    ReDim arrCsvRow(rngRow.Cells.Count - 1)
    Dim rngCell As Range
    Dim lngIndex As Long

    lngIndex = 0

    For Each rngCell In rngRow.Cells
        arrCsvRow(lngIndex) = CsvFormatString(rngCell.Text)
        lngIndex = lngIndex + 1
    Next rngCell


    CsvFormatRow = Join(arrCsvRow, ",") & strRowEnd

End Function

Sub CsvExportRange( _
        rngRange As Range, _
        Optional strFileName As Variant _
    )

    Dim rngRow As Range
    Dim objStream As Object

    If IsMissing(strFileName) Or IsEmpty(strFileName) Then
        strFileName = Application.GetSaveAsFilename( _
            InitialFileName:=ActiveWorkbook.Path & "\" & rngRange.Worksheet.Name & ".csv", _
            FileFilter:="CSV (*.csv), *.csv", _
            Title:="Export CSV")
    End If

    Set objStream = CreateObject("ADODB.Stream")
    objStream.Type = 2
    objStream.Charset = strCharset
    objStream.Open

    For Each rngRow In rngRange.Rows
        objStream.WriteText CsvFormatRow(rngRow)
    Next rngRow

    objStream.SaveToFile strFileName, 2
    objStream.Close

End Sub

Sub CsvExportSelection()
    CsvExportRange ActiveWindow.Selection
End Sub

Sub CsvExportSheet(varSheetIndex As Variant)

    Dim wksSheet As Worksheet
    Set wksSheet = Sheets(varSheetIndex)

    CsvExportRange wksSheet.UsedRange

End Sub

Answer 3

Update of this code. I used this one to change all .csv files in a specified folder (labeled "Bron") and save them as csv utf-8 in another folder (labeled "doel")

Sub SaveAsUTF8()

Dim fsT As Variant, tFileToOpen As String, tFileToSave As String
Dim Message As String
Dim wb As Workbook
Dim fileName As String

Set wb = ActiveWorkbook

With Application
.ScreenUpdating = False
.DisplayAlerts = False
End With

Message = "Source folder incorrect"
SourceFolder = wb.Worksheets("Menu").Range("Bron") & "\"
If Dir(SourceFolder, vbDirectory) = "" Or IsEmpty(SourceFolder) Then GoTo errorhandler

Message = "Target folder incorrect"
TargetFolder = wb.Worksheets("Menu").Range("Doel") & "\"
If Dir(TargetFolder, vbDirectory) = "" Or IsEmpty(TargetFolder) Then GoTo errorhandler

fileName = Dir(SourceFolder & "\*.csv", vbNormal)

Message = "No files available."
If Len(fileName) = 0 Then GoTo errorhandler

Do Until fileName = ""

    tFileToOpen = SourceFolder & fileName
    tFileToSave = TargetFolder & fileName

    tFileToOpenPath = tFileToOpen
    tFileToSavePath = tFileToSave

Set fsT = CreateObject("ADODB.Stream"): 'Create Stream object
fsT.Type = 2: 'Specify stream type – we want To save text/string data.
fsT.Charset = "utf-8": 'Specify charset For the source text data.

fsT.Open: 'Open the stream
fsT.LoadFromFile tFileToOpenPath: 'And write the file to the object stream

fsT.SaveToFile tFileToSavePath, 2: 'Save the data to the named path

fileName = Dir()

Loop

Message = "Okay to remove all old files?"
If QuestionMessage(Message) = False Then
    GoTo the_end
Else
    On Error Resume Next
    Kill SourceFolder & "*.csv"
    On Error GoTo errorhandler
End If

the_end:
With Application
.ScreenUpdating = True
.DisplayAlerts = True
End With
Exit Sub

errorhandler:
With Application
.ScreenUpdating = True
.DisplayAlerts = True
End With
CriticalMessage (Message)
Exit Sub

End Sub

'----------

Function CriticalMessage(Message As String)

MsgBox Message

End Function

'----------

Function QuestionMessage(Message As String)

If MsgBox(Message, vbQuestion + vbYesNo) = vbNo Then
QuestionMessage = False
Else
QuestionMessage = True
End If

End Function