excel vba save sheet to CSV with UTF 8 encoding
'VBA routine to save the currently active worksheet to a CSV file
'without losing focus AND retaining Unicode characters. This routine
'is extremely fast (instantaneous) and produces no flicker:
Sub SaveSheetAsCSV()
Dim i&, j&, iMax&, jMax&, chk$, listsep$, s$, v
Const Q = """", QQ = Q & Q
listsep = Application.International(xlListSeparator)
chk = Q & "," & listsep & "," & vbLf
With ActiveSheet
v = .UsedRange.Value
iMax = UBound(v, 1): jMax = UBound(v, 2)
For i = 1 To iMax
For j = 1 To jMax
If Not IsError(v(i, j)) Then s = v(i, j) Else s = .Cells(i, j).Text
If AnyIn(s, Q, listsep, vbLf) Then s = Replace(s, Q, QQ): s = Q & s & Q
BuildString s & listsep
Next
If i < iMax Then BuildString vbCrLf, -1
Next
s = .Parent.Path & Application.PathSeparator & Left(.Parent.Name, InStrRev(.Parent.Name, ".")) & .Name & ".csv"
SaveStringAsTextFile BuildString(Done:=True, Adjust:=-1), s
End With
End Sub
Function BuildString(Optional txt$, Optional Adjust&, Optional Done As Boolean, Optional Size = "20e6")
Static p&, s$
If Len(p) Then p = p + adjust
If Done Then BuildString = Left(s, p - 1): p = 0: s = "": Exit Function
If p = 0 Then: p = 1: s = Space(Size)
Mid$(s, p, Len(txt)) = txt
p = p + Len(txt)
End Function
Function AnyIn(s$, ParamArray checks()) As Boolean
Dim e
For Each e In checks
If InStrB(s, e) Then AnyIn = True: Exit Function
Next
End Function
Function SaveStringAsTextFile$(s$, fName$)
Const adSaveCreateOverWrite = 2
With CreateObject("ADODB.Stream")
.Charset = "utf-8"
.Open
.WriteText s
.SetEOS
.SaveToFile fName, adSaveCreateOverWrite
.Close
End With
End Function