使用 VBA 将 XSLX 转换为 CSV

debugcn 发表于 Dev

brianvu1892

首先，我对 VBA 非常业余，所以我需要你的帮助！

我使用下面的代码转换.xlsx为.csv但不知何故该字符不好看。英语还可以，但越南字符不容易看到。

例如，复制此文本“您今天如何评价我们的餐厅？” 到 xlsx 文件并使用下面的代码转换为 csv。然后字符显示为“Ba?n ?a?nh gia?ve?ha?ha?ng cu?a chu?ng to?i ho?m now like?the?na?o?”

任何人都可以帮我解决这个问题！先感谢您

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

李戴

您必须使用编码 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

本文收集自互联网，转载请注明来源。

如有侵权，请联系[email protected] 删除。