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
Option Explicit Private Sub Workbook_Open() Call AddNewMenu End Sub
コメント