4

我想使用 VBA 导出我在 UTF-8 CSV 中创建的文件。通过搜索留言板，我发现了以下将文件转换为 UTF-8 的代码（来自此线程）：

Sub SaveAsUTF8() 

    Dim fsT, tFileToOpen, tFileToSave As String 

    tFileToOpen = InputBox("Enter the name and location of the file to convert" & vbCrLf & "With full path and filename ie. C:\MyFolder\ConvertMe.Txt") 
    tFileToSave = InputBox("Enter the name and location of the file to save" & vbCrLf & "With full path and filename ie. C:\MyFolder\SavedAsUTF8.Txt") 

    tFileToOpenPath = tFileToOpen 
    tFileToSavePath = tFileToSave 

Set fsT = CreateObject("ADODB.Stream"): 'Create Stream object
fsT.Type = 2: 'Specify stream type – we want To save text/string data.
fsT.Charset = "utf-8": 'Specify charset For the source text data.

fsT.Open: 'Open the stream
fsT.LoadFromFile tFileToOpenPath: 'And write the file to the object stream

fsT.SaveToFile tFileToSavePath, 2: 'Save the data to the named path

End Sub

但是，此代码仅将非 UTF-8 文件转换为 UTF-8。如果我将我的文件保存为非 UTF-8 格式，然后将其转换为 UTF-8，它已经丢失了其中包含的所有特殊字符，从而使该过程变得毫无意义！

我要做的是以 UTF-8 (CSV) 格式保存一个打开的文件。有没有办法用 VBA 做到这一点？

nb 我也在“ozgrid”论坛上问过这个问题。如果我找到解决方案，将关闭两个线程。

4

3 回答 3

9

最后在 Office 2016 中，您可以简单地以 UTF8 格式保存为 CSV。

Sub SaveWorkSheetAsCSV()

Dim wbNew As Excel.Workbook
Dim wsSource As Excel.Worksheet, wsTemp As Excel.Worksheet
Dim name As String



    Set wsSource = ThisWorkbook.Worksheets(1)
    name = "test"
    Application.DisplayAlerts = False 'will overwrite existing files without asking
    Set wsTemp = ThisWorkbook.Worksheets(1)
    Set wbNew = ActiveWorkbook
    Set wsTemp = wbNew.Worksheets(1)
    wbNew.SaveAs name & ".csv", xlCSVUTF8 'new way
    wbNew.Close
    Application.DisplayAlerts = True

End Sub

这会将工作表 1 保存到名为 test 的 csv 文件中。

于 2018-03-21T06:40:15.603 回答
4

更新此代码。我用这个来更改指定文件夹（标记为“Bron”）中的所有 .csv 文件，并将它们保存为另一个文件夹中的 csv utf-8（标记为“doel”）

Sub SaveAsUTF8()

Dim fsT As Variant, tFileToOpen As String, tFileToSave As String
Dim Message As String
Dim wb As Workbook
Dim fileName As String

Set wb = ActiveWorkbook

With Application
.ScreenUpdating = False
.DisplayAlerts = False
End With

Message = "Source folder incorrect"
SourceFolder = wb.Worksheets("Menu").Range("Bron") & "\"
If Dir(SourceFolder, vbDirectory) = "" Or IsEmpty(SourceFolder) Then GoTo errorhandler

Message = "Target folder incorrect"
TargetFolder = wb.Worksheets("Menu").Range("Doel") & "\"
If Dir(TargetFolder, vbDirectory) = "" Or IsEmpty(TargetFolder) Then GoTo errorhandler

fileName = Dir(SourceFolder & "\*.csv", vbNormal)

Message = "No files available."
If Len(fileName) = 0 Then GoTo errorhandler

Do Until fileName = ""

    tFileToOpen = SourceFolder & fileName
    tFileToSave = TargetFolder & fileName

    tFileToOpenPath = tFileToOpen
    tFileToSavePath = tFileToSave

Set fsT = CreateObject("ADODB.Stream"): 'Create Stream object
fsT.Type = 2: 'Specify stream type – we want To save text/string data.
fsT.Charset = "utf-8": 'Specify charset For the source text data.

fsT.Open: 'Open the stream
fsT.LoadFromFile tFileToOpenPath: 'And write the file to the object stream

fsT.SaveToFile tFileToSavePath, 2: 'Save the data to the named path

fileName = Dir()

Loop

Message = "Okay to remove all old files?"
If QuestionMessage(Message) = False Then
    GoTo the_end
Else
    On Error Resume Next
    Kill SourceFolder & "*.csv"
    On Error GoTo errorhandler
End If

the_end:
With Application
.ScreenUpdating = True
.DisplayAlerts = True
End With
Exit Sub

errorhandler:
With Application
.ScreenUpdating = True
.DisplayAlerts = True
End With
CriticalMessage (Message)
Exit Sub

End Sub

'----------

Function CriticalMessage(Message As String)

MsgBox Message

End Function

'----------

Function QuestionMessage(Message As String)

If MsgBox(Message, vbQuestion + vbYesNo) = vbNo Then
QuestionMessage = False
Else
QuestionMessage = True
End If

End Function
于 2014-04-18T13:06:33.927 回答
2

这是我基于Excel VBA 的解决方案 - 导出到 UTF-8，之前 user3357963 已链接到该解决方案。它包括用于导出范围和选择的宏。

Option Explicit

Const strDelimiter = """"
Const strDelimiterEscaped = strDelimiter & strDelimiter
Const strSeparator = ","
Const strRowEnd = vbCrLf
Const strCharset = "utf-8"

Function CsvFormatString(strRaw As String) As String

    Dim boolNeedsDelimiting As Boolean

    boolNeedsDelimiting = InStr(1, strRaw, strDelimiter) > 0 _
        Or InStr(1, strRaw, Chr(10)) > 0 _
        Or InStr(1, strRaw, strSeparator) > 0

    CsvFormatString = strRaw

    If boolNeedsDelimiting Then
        CsvFormatString = strDelimiter & _
            Replace(strRaw, strDelimiter, strDelimiterEscaped) & _
            strDelimiter
    End If

End Function

Function CsvFormatRow(rngRow As Range) As String

    Dim arrCsvRow() As String
    ReDim arrCsvRow(rngRow.Cells.Count - 1)
    Dim rngCell As Range
    Dim lngIndex As Long

    lngIndex = 0

    For Each rngCell In rngRow.Cells
        arrCsvRow(lngIndex) = CsvFormatString(rngCell.Text)
        lngIndex = lngIndex + 1
    Next rngCell


    CsvFormatRow = Join(arrCsvRow, ",") & strRowEnd

End Function

Sub CsvExportRange( _
        rngRange As Range, _
        Optional strFileName As Variant _
    )

    Dim rngRow As Range
    Dim objStream As Object

    If IsMissing(strFileName) Or IsEmpty(strFileName) Then
        strFileName = Application.GetSaveAsFilename( _
            InitialFileName:=ActiveWorkbook.Path & "\" & rngRange.Worksheet.Name & ".csv", _
            FileFilter:="CSV (*.csv), *.csv", _
            Title:="Export CSV")
    End If

    Set objStream = CreateObject("ADODB.Stream")
    objStream.Type = 2
    objStream.Charset = strCharset
    objStream.Open

    For Each rngRow In rngRange.Rows
        objStream.WriteText CsvFormatRow(rngRow)
    Next rngRow

    objStream.SaveToFile strFileName, 2
    objStream.Close

End Sub

Sub CsvExportSelection()
    CsvExportRange ActiveWindow.Selection
End Sub

Sub CsvExportSheet(varSheetIndex As Variant)

    Dim wksSheet As Worksheet
    Set wksSheet = Sheets(varSheetIndex)

    CsvExportRange wksSheet.UsedRange

End Sub
于 2016-03-31T14:28:52.510 回答