Convert XSLX to CSV using VBA [duplicate]

Question

This question already has an answer here:

• Export sheet as UTF-8 CSV file (using Excel-VBA) 3 answers

First of all, I'm quite amateur on VBA that why i need your help!

I use the code below to convert .xlsx to .csv but somehow the character is not good to see.English is ok but Vietnamese character is not easy to see.

For example, copy this text" Bạn đánh giá về nhà hàng của chúng tôi hôm nay như thế nào?" to xlsx file and use code below to convert to csv. Then the character is shown like this "Ba?n ?a?nh gia? vê? nha? ha?ng cu?a chu?ng to?i ho?m nay nhu? thê? na?o?"

Anyone can help me with this! thank you in advance

Dim fso: set fso = CreateObject("Scripting.FileSystemObject") ' directory in which this script is currently running CurrentDirectory = fso.GetAbsolutePathName(".")

Set folder = fso.GetFolder(CurrentDirectory)

For each file In folder.Files

If fso.GetExtensionName(file) = "xlsx" Then

    pathOut = fso.BuildPath(CurrentDirectory, fso.GetBaseName(file)+".csv")

    Dim oExcel
    Set oExcel = CreateObject("Excel.Application")
    Dim oBook
    Set oBook = oExcel.Workbooks.Open(file)
    oBook.SaveAs pathOut, 6
    oBook.Close False
    oExcel.Quit
End If Next

Answer 1

You havet to use Encode UTF-8. adostream assist this function.

Sub SaveXlsToCsvFiles()
    Dim FileName As String
    Dim Ws As Worksheet, Wb As Workbook
    Dim rngDB As Range
    Dim r As Long, c As Long
    Dim pathOut As String
    Dim File As Object, folder As Object

Dim fso: Set fso = CreateObject("Scripting.FileSystemObject") ' directory in which this script is currently running CurrentDirectory = fso.GetAbsolutePathName(".")

'Set folder = fso.GetFolder(CurrentDirectory)
Set folder = fso.GetFolder(ThisWorkbook.Path)
For Each File In folder.Files

    If fso.GetExtensionName(File) = "xlsx" Then
        If File.Name <> ThisWorkbook.Name Then
            pathOut = fso.BuildPath(CurrentDirectory, fso.GetBaseName(File) + ".csv")
            With File
                Set Wb = Workbooks.Open(.ParentFolder & "\" & .Name)
                Set Ws = Wb.Sheets(1)
                With Ws
                    r = .Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
                    c = .Cells.Find("*", SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column
                    Set rngDB = .Range("a1", .Cells(r, c))
                End With
                TransToCSV pathOut, rngDB
                Wb.Close (0)
            End With
        End If
    End If
Next
Set fso = Nothing
    MsgBox ("Files Saved Successfully")
End Sub
Sub TransToCSV(myfile As String, rng As Range)

    Dim vDB, vR() As String, vTxt()
    Dim i As Long, n As Long, j As Integer
    Dim objStream
    Dim strTxt As String

    Set objStream = CreateObject("ADODB.Stream")
    vDB = rng
    For i = 1 To UBound(vDB, 1)
        n = n + 1
        ReDim vR(1 To UBound(vDB, 2))
        For j = 1 To UBound(vDB, 2)
            vR(j) = vDB(i, j)
        Next j
        ReDim Preserve vTxt(1 To n)
        vTxt(n) = Join(vR, ",")
    Next i
    strTxt = Join(vTxt, vbCrLf)
    With objStream
        .Charset = "utf-8"
        .Open
        .WriteText strTxt
        .SaveToFile myfile, 2
        .Close
    End With
    Set objStream = Nothing

End Sub