VBAを使用してXSLXをCSVに変換する

Question

まず、VBAで私は非常に素人です。

.xlsxを.csvに変換するには、以下のコードを使用しますが、なんとなく文字は見栄えが悪いです。英国は大丈夫ですが、ベトナム人のキャラクターは見やすいものではありません。

たとえば、次のテキストをコピーします。「この文書をコピーしてください」と表示されます。 xlsxファイルに変換し、以下のコードを使用してcsvに変換します。次に、このキャラクターは、このように表示されます。「バーン・ナンバー・ヴァン・ナハッハ・ハイング・ナウ・イット・ユー・ホー・ナイン・ナー・ナ・ザ・ナ・ナー・オー？

誰もが私を助けることができます！事前にありがとうございます

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

あなたはEncode UTF-8を使用しています。 adostreamはこの機能を支援します。

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