excel export unicode 8 code example

Example: excel 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