Question

我尝试创建一个将Excel工作表转换为xml的VBA宏。问题是excel数据包含特殊字符。我在论坛中搜索了一些帮助，并猜测ADOB.stream解决方案可以解决我的问题。但是我无法将其集成到我的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

excel to xml以UTF-8保存输出

1 个答案: