excel到xml以UTF-8保存输出

Question

我试图创建一个将 excel 工作表转换为 xml 的 VBA 宏。问题是excel数据包含特殊字符。我在论坛中搜索了一些帮助并猜测 ADOB.stream-solution 是可以解决我的问题的解决方案。但我无法将它集成到我的 VBA 代码中。到目前为止，我得到了以下代码：

Public Sub ExcelToXML()

On Error GoTo ErrorHandler


Dim colIndex As Integer
Dim rwIndex As Integer
Dim asCols() As String
Dim oWorkSheet As Worksheet
Dim sName As String
Dim lCols As Long, lRows As Long
Dim iFileNum As Integer


Set oWorkSheet = ThisWorkbook.Worksheets(1)
sName = oWorkSheet.Name
lCols = oWorkSheet.Columns.Count
lRows = oWorkSheet.Rows.Count

Set objstream = CreateObject("ADODB.Stream")

objstream.Charset = "utf-8"
objstream.Mode = 3
objstream.Type = 2
objstream.Open

ReDim asCols(lCols) As String

iFileNum = FreeFile
Open "C:\temp\test5.xml" For Output As #iFileNum

Worksheets("Sheet1").Range("A1:Z1").Replace _
What:=" ", Replacement:="_", _
SearchOrder:=xlByColumns, MatchCase:=True

For i = 0 To lCols - 1
'Assumes no blank column names
If Trim(Cells(1, i + 1).Value) = "" Then Exit For
asCols(i) = Cells(1, i + 1).Value
Next i

If i = 0 Then GoTo ErrorHandler
lCols = i

objstream.WriteText "<?xml version=""1.0"" encoding=""UTF-8""?>"
objstream.WriteText "<" & "DATA" & ">"
For i = 2 To lRows
If Trim(Cells(i, 1).Value) = "" Then Exit For
obj.stream.WriteText "<" & "PROC" & ">"

For j = 1 To lCols

    If Trim(Cells(i, j).Value) <> "" Then
       objstream.WriteText "  <" & asCols(j - 1) & ">"
       objstream.WriteText Trim(Cells(i, j).Value)
       objstream.WriteText "</" & asCols(j - 1) & ">"
       DoEvents 'OPTIONAL
    End If
Next j
objstream.WriteText " </" & "PROC" & ">"
Next i

objstream.WriteText "</" & "DATA" & ">"

ErrorHandler:
If iFileNum > 0 Then Close #iFileNum

objstream.SaveToFile "C:\temp\test6.xml", 2
objstream.Close
Set AdoS = Nothing


Exit Sub

End Sub

很遗憾，输出文件是空的。提前感谢您能给我的任何帮助！

Answer 1

不要尝试手动创建 XML 文件 - 已经有非常强大的工具可供您使用。在这种情况下，我会使用 MSXML2 对象。这些原生支持 UTF8，因此您根本不需要处理字符编码或文件 IO。代码结构与直接写文本基本相同，只是你添加节点而不是写<node>、value、</node>，并尽量保持结构直：

 'Add a reference to Microsoft XML, v6.0
Sub ExcelToXML()
    Worksheets("Sheet1").Range("A1:Z1").Replace _
        What:=" ", Replacement:="_", _
        SearchOrder:=xlByColumns, MatchCase:=True

    With New DOMDocument
        'Add XML header
        .appendChild .createProcessingInstruction("xml", "version=""1.0"" encoding=""utf-8""")
        'Add the root node
        Dim root As IXMLDOMElement
        Set root = .createElement("DATA")
        .appendChild root
        'Work with an array, not the actual worksheet.
        Dim data() As Variant
        data = Worksheets("Sheet1").UsedRange.Value
        For r = LBound(data, 1) + 1 To UBound(data, 1)
            If Trim$(data(r, 1)) = vbNullString Then Exit For
            Dim proc As IXMLDOMElement
            'Create a PROC node for the row.
            Set proc = root.appendChild(.createElement("PROC"))
            For c = LBound(data, 2) To UBound(data, 2)
                If Trim$(data(r, c)) <> vbNullString Then
                    'Add a child for each column.
                    Dim child As IXMLDOMElement
                    Set child = proc.appendChild(.createElement(data(1, c)))
                    child.appendChild .createTextNode(Trim$(data(r, c)))
                End If
            Next
        Next
        'Write the file.
        .Save "C:\temp\test6.xml"
    End With
End Sub