Use ADODB to save Sheet pages in Excel as UTF8 encoded CSV

Public Sub WriteCSV()
Set wkb = ActiveSheet
Dim fileName As String
Dim MaxCols As Integer
fileName = Application.GetSaveAsFilename("", "CSV File (*.csv), *.csv")

If fileName = "False" Then
End
End If

On Error GoTo eh
Const adTypeText = 2
Const adSaveCreateOverWrite = 2

Dim BinaryStream
Set BinaryStream = CreateObject("ADODB.Stream")
BinaryStream.Charset = "UTF-8"
BinaryStream.Type = adTypeText
BinaryStream.Open

For r = 1 To 10
s = ""
c = 1
While Not IsEmpty(wkb.Cells(r, c).Value)
s = s & wkb.Cells(r, c).Value & ","
c = c + 1
Wend
BinaryStream.WriteText s, 1
Next r

BinaryStream.SaveToFile fileName, adSaveCreateOverWrite
BinaryStream.Close

MsgBox "CSV generated successfully"

eh:

End Sub

 PS: You need to click the macro once on each Sheet page, pop up the window, select Save as name, click OK, save as UTF8 format CSV, and only export 10 lines each, stop when the content on the line is empty

Guess you like

Origin http://43.154.161.224:23101/article/api/json?id=326513293&siteId=291194637