Excel VBA: Output Sheet as UTF-8 CSV

Save Excel Sheet as UTF-8 CSV file

The biggest problem of Excel is that Excel does not support saving file as UTF-8 CSV format.
I have googled and tried to find the solution for saving excel as UTF-8 CSV but all of them requires 2 steps - 1) saving Excel file as Unicode csv 2) Open it by text editor and save it again as UTF-8 CSV.

If you are a software developer, it is easy to write Java or C# program to manipulate Excel.
But it means people (non developer users) need to install or launch the application.
So I have wrriten Excel VBA addin for saving Excel sheet as UTF-8 CSV file so that we can save UTF-8 excel files only using Excel.

Code for saving UTF-8 CSV

Okie!, here is my solution!
Sme notes for the code:

• The code saves an active sheet to UTF-8 CSV file in temp folder.
• The error handring part is not robust. I have only wrriten minimum error handling. You might need to add your custome error handring.
• If you are okay to add BOM on the file, please remove the corresponding part for adding BOM.

Sub SaveAsCSV()
On Error GoTo ErrorHandler

    Const ROW_LIMIT As Long = 1000
    Const OUTPUT_DIR = "C:\temp\"
    
    '==============================
    ' Get Range
    '==============================
    Dim maxRow As Long
    Dim maxCol As Long
    
    If ActiveSheet Is Nothing Then
       MsgBox "Sheet Not Found!", vbExclamation
       Exit Sub
    End If
    
 
    With ActiveSheet.UsedRange
        maxRow = .Rows.Count
        maxCol = .Columns.Count
    End With
    
    If maxRow < 2 Then
       MsgBox "Data is Empty!", vbExclamation
       Exit Sub
    End If
    
    Dim fileIndex As Long: fileIndex = 1
 
    '==============================
    ' Prepare stream
    '==============================
    Dim outStream As ADODB.Stream
 
 
    '==============================
    ' Write data to stream
    '==============================
    Dim r As Long
    Dim c As Long
    Dim line As String
    Dim Data As Variant
    Dim shop As String
    Dim header As String
     
    Dim isFileOutput As Boolean: isFileOutput = False
    Dim isNewFile As Boolean: isNewFile = True
     
     
    With ActiveSheet
    Data = .Range("A1:" & Col_Letter(maxCol) & .Range("A1").End(xlDown).Row)
    End With
         
    '==============================
    ' Write header row
    '==============================
    header = """" & Data(1, 1) & """"
    For c = 2 To maxCol
        If Data(1, c) = "" Then
           header = header & "," & """"""
        Else
           header = header & ",""" & Replace(Trim(Data(1, c)), """", """""") & """"
        End If
    Next
    
    Dim baseName As String: baseName = GetBaseFileName()
    
    '==============================
    ' Write data rows
    '==============================
    For r = 2 To maxRow
        Application.StatusBar = String(Int(r / 1000), "*")
        If isNewFile Then
            ' create new out stream for next file
            Set outStream = New ADODB.Stream
        
            With outStream
                .Charset = "UTF-8"
                .Type = 2       'adTypeText
                .Open
            End With
            outStream.WriteText header, adWriteLine
            isNewFile = False
        End If
        
        ' Data line
        ' 1st column
        line = """" & Data(r, 1) & """"
        
        ' after 1st column
        For c = 2 To maxCol
            If Data(r, c) = "" Then
               line = line & "," & """"""
            Else
               line = line & ",""" & Replace(Trim(Data(r, c)), """", """""") & """"
            End If
        Next
        
        outStream.WriteText line, adWriteLine
        
        ' File output
        isFileOutput = (r Mod ROW_LIMIT = 0 Or r = maxRow)
        If isFileOutput Then
            ' Skip BOM
            With outStream
                .Position = 0
                .Type = 1       'adTypeBinary
                .Position = 3   'skip 3 byte in order to remive BOM
            End With
            
            ' stream for copy
            Dim csvStream As ADODB.Stream
            Set csvStream = New ADODB.Stream
         
            ' open binary mode
            csvStream.Type = adTypeBinary
            csvStream.Open
         
            ' copy data after BOM
            outStream.CopyTo csvStream
            csvStream.SaveToFile (OUTPUT_DIR & baseName & "_" & fileIndex & ".csv"), adSaveCreateOverWrite
            outStream.Close
            
            fileIndex = fileIndex + 1
            isNewFile = True
        End If
    Next
    Application.StatusBar = False
    MsgBox "Output " & fileIndex - 1 & " csv files on " & vbCrLf & OUTPUT_DIR & " from " & ActiveSheet.Name & " in " & Application.ActiveWorkbook.Name, vbInformation, "Csv Output"
    Exit Sub
ErrorHandler:
    Application.StatusBar = False
    MsgBox "Error Details:" & Err.Description, vbCritical, "Error"
End Sub

Private Function Col_Letter(lngCol As Long) As String
Dim vArr: vArr = Split(Cells(1, lngCol).Address(True, False), "$")
Col_Letter = vArr(0)
End Function

Private Function GetBaseFileName()
  Dim extIndex As Integer: extIndex = InStrRev(Application.ActiveWorkbook.Name, ".")
  If extIndex > 0 Then
    GetBaseFileName = Left(Application.ActiveWorkbook.Name, extIndex - 1)
  Else
    GetBaseFileName = Application.ActiveWorkbook.Name
  End If
End Function

Adding the Funtionality to Menu

If you would like to add this functionality to Excel, you need to create menu which executes the UTF-8 to csv macro and add it to Excel menu.

• Create a standard Excel VBA module in VBA editor.
• Copy and paste the above main VBA code (SaveAsCSV funciton etc.) to the module created in the previous step.
• Also add the folliwng code which adds custom menu to Excel

Sub AddNewMenu()

    On Error GoTo ErrHand

    Dim cbrCmd As CommandBar
    Dim cbcMenu As CommandBarControl

    'Create menu
    Set cbrCmd = Application.CommandBars("Worksheet Menu Bar")

    'Delete menu if it already exists
    cbrCmd.Controls("UTF-8 CSV").Delete

    'Add menu
    Set cbcMenu = cbrCmd.Controls.Add(Type:=msoControlPopup)
    cbcMenu.Caption = "UTF-8 CSV"
    cbcMenu.Tag = "UTF-8 CSV"

    With cbcMenu.Controls.Add(Type:=msoControlButton)
        .Caption = " UTF-8 CSV"
        .OnAction = "SaveAsCSV"
        .FaceId = 3
    End With

    Set cbrCmd = Nothing
    Set cbcMenu = Nothing

    Exit Sub

ErrHand:

    If Err.Number = 5 Then
       Resume Next
    Else
       MsgBox Err.Description
    End If

End Sub

• Open "ThisWorkbook" and copy and paste the fowlling code.

Option Explicit

Private Sub Workbook_Open()
  Call AddNewMenu
End Sub

• Save the file as Excel Addin - xla file.
• Load the xla file you saved to Excel. How to add addin to Excel is outside theme of this post :p Please google it yourself ;)
• Congratulations! You can see the Excel Menu for saving excel sheet as UTF-8 CSV file. If you click "UTF-8 CSV", the macro should work.