[英]Export sheet as UTF-8 CSV file (using Excel-VBA)
我想使用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这样做?
我也在'ozgrid'论坛上问了这个问题。 如果我找到解决方案,将关闭两个线程。
更新此代码。 我使用这个来更改指定文件夹中的所有.csv文件(标记为“Bron”)并将它们保存为另一个文件夹中的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
最后在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中。
这是我的基于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
声明:本站的技术帖子网页,遵循CC BY-SA 4.0协议,如果您需要转载,请注明本站网址或者原文地址。任何问题请咨询:yoyou2525@163.com.