如何将 VBA 中的 sheet/column 导出为 UTF-8 格式的 XML
How to export sheet/column in VBA to XML in UTF-8 formatting
我写了一个宏,它在某个 sheet 的 A 列中输出 xml 行(格式正确)。因此,sheet 中的每一行都应对应于 xml 文件中的 1 行。如果我将此列复制粘贴到记事本中,然后将其另存为 .xml(删除每行前后自动放置的“-tags”),我就有了所需的文件。宏应该生成几个文件,因此对每个文件手动执行此操作并不实用。
我找到了以下代码来执行保存作业:
strFileName = Application.ActiveWorkbook.Path & "\" & NameOfTheFile & ".xml"
Sheets(NameOfSheetContainingData).SaveAs Filename:=strFileName, FileFormat:=xlTextPrinter, CreateBackup:=False
除 UTF-8 格式外,这非常有效。我在 excel 中有一个 'é',它在 xml 文件中变成了一个 'xE9'。
如果有人能帮我解决这个问题,我将非常感激:)
尝试
Sub SaveUTF8()
Const NameOfTheFile = "test"
Dim FSO, ts, ar, strFilename As String, s As String
Dim i As Long, t0 As Single: t0 = Timer
strFilename = ActiveWorkbook.Path & "\" & NameOfTheFile & ".xml"
Set FSO = CreateObject("Scripting.FileSystemObject")
Set ts = FSO.createTextfile(strFilename, 1, 1) ' oversrite, utf8
ar = Sheets(1).UsedRange.Columns(1).Value2 'NameofSheetContainingData
For i = LBound(ar) To UBound(ar)
s = s & ar(i, 1) & vbCrLf
If i Mod 1000 = 0 Then
ts.write s
s = ""
End If
Next
ts.write s
ts.Close
MsgBox strFilename & " created in " & Int(Timer - t0) & " seconds"
End Sub
备选
Sub SaveUTF8_2()
Const NameOfTheFile = "test"
Dim strFilename As String, cell As Range
Dim t0 As Single: t0 = Timer
strFilename = ActiveWorkbook.Path & "\" & NameOfTheFile & ".xml"
Dim objStream
Set objStream = CreateObject("ADODB.Stream")
With objStream
.Type = 2 'adTypeText
.Open
.Charset = "UTF-8"
For Each cell In Sheets(1).UsedRange.Columns(1).Cells
.writetext cell.Value2, 1 'adWriteLine
Next
.Position = 0
.SaveToFile strFilename, 2 'adSaveCreateOverWrit
End With
objStream.Close
MsgBox strFilename & " created in " & Int(Timer - t0) & " seconds"
End Sub
Sub testdata()
Sheet1.Range("A1:A300000").Value2 = _
"<tag atr1=""attribute one"" atr2=""attribute two"">some text here ééé</tag>"
End Sub
更新 - 批量写入 1000 行
update2 - 添加了备选方案
我写了一个宏,它在某个 sheet 的 A 列中输出 xml 行(格式正确)。因此,sheet 中的每一行都应对应于 xml 文件中的 1 行。如果我将此列复制粘贴到记事本中,然后将其另存为 .xml(删除每行前后自动放置的“-tags”),我就有了所需的文件。宏应该生成几个文件,因此对每个文件手动执行此操作并不实用。
我找到了以下代码来执行保存作业:
strFileName = Application.ActiveWorkbook.Path & "\" & NameOfTheFile & ".xml"
Sheets(NameOfSheetContainingData).SaveAs Filename:=strFileName, FileFormat:=xlTextPrinter, CreateBackup:=False
除 UTF-8 格式外,这非常有效。我在 excel 中有一个 'é',它在 xml 文件中变成了一个 'xE9'。
如果有人能帮我解决这个问题,我将非常感激:)
尝试
Sub SaveUTF8()
Const NameOfTheFile = "test"
Dim FSO, ts, ar, strFilename As String, s As String
Dim i As Long, t0 As Single: t0 = Timer
strFilename = ActiveWorkbook.Path & "\" & NameOfTheFile & ".xml"
Set FSO = CreateObject("Scripting.FileSystemObject")
Set ts = FSO.createTextfile(strFilename, 1, 1) ' oversrite, utf8
ar = Sheets(1).UsedRange.Columns(1).Value2 'NameofSheetContainingData
For i = LBound(ar) To UBound(ar)
s = s & ar(i, 1) & vbCrLf
If i Mod 1000 = 0 Then
ts.write s
s = ""
End If
Next
ts.write s
ts.Close
MsgBox strFilename & " created in " & Int(Timer - t0) & " seconds"
End Sub
备选
Sub SaveUTF8_2()
Const NameOfTheFile = "test"
Dim strFilename As String, cell As Range
Dim t0 As Single: t0 = Timer
strFilename = ActiveWorkbook.Path & "\" & NameOfTheFile & ".xml"
Dim objStream
Set objStream = CreateObject("ADODB.Stream")
With objStream
.Type = 2 'adTypeText
.Open
.Charset = "UTF-8"
For Each cell In Sheets(1).UsedRange.Columns(1).Cells
.writetext cell.Value2, 1 'adWriteLine
Next
.Position = 0
.SaveToFile strFilename, 2 'adSaveCreateOverWrit
End With
objStream.Close
MsgBox strFilename & " created in " & Int(Timer - t0) & " seconds"
End Sub
Sub testdata()
Sheet1.Range("A1:A300000").Value2 = _
"<tag atr1=""attribute one"" atr2=""attribute two"">some text here ééé</tag>"
End Sub
更新 - 批量写入 1000 行
update2 - 添加了备选方案