将工作表导出为 UTF-8 CSV 文件（使用 Excel-VBA）

Export sheet as UTF-8 CSV file (using Excel-VBA)

提问by CaptainProg

I would like to export a file I have created in UTF-8 CSV using VBA. From searching message boards, I have found the following code that converts a file to UTF-8 (from this thread):

我想使用 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 

However, this code only converts a non-UTF-8 file to UTF-8. If I were to save my file in non-UTF-8 and then convert it to UTF-8, it would have already lost all the special characters it contained, thus rendering the process pointless!

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

What I'm looking to do is save an open file in UTF-8 (CSV). Is there any way of doing this with VBA?

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

n.b. I have also asked this question on the 'ozgrid' forum. Will close both threads together if I find a solution.

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

回答by Raymond

Finally in Office 2016, you can simply savs as CSV in UTF8.

最后，在 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

This will save the worksheet 1 into csv named test.

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

回答by Alex

Update of this code. I used this one to change all .csv files in a specified folder (labeled "Bron") and save them as csv utf-8 in another folder (labeled "doel")

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

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

回答by Bryn

Here's my solution based on Excel VBA - export to UTF-8, which user3357963 linked to earlier. It includes macros for exporting a range and a selection.

这是我基于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