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
