使用vba脚本将xlsx转换为csv [英] Convert xlsx to csv using vba script

问题描述

首先，我很熟悉VBA，为什么我需要你的帮助！

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

例如，复制此文本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？

任何人都可以帮助我这个！感谢你提前

  Dim fso：set fso = CreateObject（Scripting.FileSystemObject）'目录，其中此脚本目前在运行CurrentDirectory = fso.GetAbsolutePathName（。）
 
设置文件夹= fso.GetFolder（CurrentDirectory）
 
对于每个文件在folder.Files 
 
如果fso.GetExtensionName（file）=xlsx然后
 
 pathOut = fso.BuildPath（CurrentDirectory，fso.GetBaseName（file）+。csv）
 
 Dim oExcel 
设置oExcel = CreateObject（Excel.Application）
 Dim oBook 
设置oBook = oExcel.Workbooks.Open（文件）
 oBook.SaveAs pathOut，6 
 oBook.Close False 
 oExcel.Quit 
 End If Next 
  

解决方案

您希望使用Encode UTF-8。 adstream帮助这个功能。

  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：设置此脚本当前正在运行的fso = CreateObject（Scripting.FileSystemObject）目录CurrentDirectory = fso.GetAbsolutePathName（。）
 
'设置文件夹= fso.GetFolder（当前目录）
设置文件夹= fso.GetFolder（ThisWorkbook.Path）
对于每个文件在folder.Files 
 
如果fso.GetExtensionName（File）=xlsx然后
如果File.Name<> ThisWorkbook.Name然后
 pathOut = fso.BuildPath（CurrentDirectory，fso.GetBaseName（File）+.csv）
使用文件
设置Wb = Workbooks.Open（.ParentFolder& \& .Name）
设置Ws = Wb.Sheets（1）
使用Ws 
r = .Cells.Find（*，SearchOrder = = xlByRows，SearchDirection：= xlPrevious ）.Row 
c = .Cells.Find（*，SearchOrder：= xlByColumns，SearchDirection：= xlPrevious）.Column 
设置rngDB = .Range（a1，.Cells（r，c） ）
结束
 TransToCSV pathOut，rngDB 
 Wb.Close（0）
结束
结束如果
结束如果
下一个
设置fso = Nothing 
 MsgBox（文件成功保存）
 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 ob jStream 
 Dim strTxt As String 
 
设置objStream = CreateObject（ADODB.Stream）
 vDB = rng 
对于i = 1 To UBound（vDB，1） 
n = n + 1 
 ReDim vR（1到UBound（vDB，2））
对于j = 1对UBound（vDB，2）
 vR（j）= vDB我，j）
下一个j 
 ReDim保存vTxt（1到n）
 vTxt（n）=加入（vR，，）
下一个i 
 strTxt =加入（vTxt，vbCrLf）
带objStream 
 .Charset =utf-8
 .Open 
 .WriteText strTxt 
 .SaveToFile myfile，2 
。关闭
结束
设置objStream =没有
 
结束子
  

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

解决方案

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脚本将xlsx转换为csv的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！