使用VBA将XSLX转换为CSV [英] Convert XSLX to CSV using VBA

问题描述

首先，我对VBA相当业余，为什么我需要您的帮助！

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

我使用下面的代码将.xlsx转换为.csv，但是不知该字符如何显示.英语还可以，但越南字符不易看到.

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.

例如，复制此文本Bạnđánhgiávềnhàhàngcủachúngtôihômnaynhưthếnào?"到xlsx文件，并使用下面的代码转换为csv.然后，该字符将显示为"Ba?n?a?nh gia?vê?nha?ha?ng cu?a chu?ng to?i ho?m nay nhu?thê?na?o?".

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

推荐答案

您不必使用Encode UTF-8. adostream辅助此功能.

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

这篇关于使用VBA将XSLX转换为CSV的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！