☰

使用 VBA 将 Excel 解析为 xml

tag-icon • tag-icon microsoft-excel microsoft-excel-2010 vba xml
使用 VBA 将 Excel 解析为 xml

我有 VBA 代码，可以将 Excel 表写入 xml 文件（实际上是逐行写入 xml 文件，标签等于列标题）。

这是代码，非常简单。

Sub MakeXML(iCaptionRow As Integer, iDataStartRow As Integer, sOutputFileName As String)
    Dim Q As String
    Dim NodeName As String
    Dim AtributName As String

    Application.ScreenUpdating = False

    Q = Chr$(34)

    Dim sXML As String

    sXML = "<?xml version=" & Q & "1.0" & Q & " encoding=" & Q & "UTF-8" & Q & "?>"
    sXML = sXML & "<root>"

    NodeName = "node"
    AtributName = "test"

    ''--determine count of columns
    Dim iColCount As Integer
    iColCount = 1
    While Trim$(Cells(iCaptionRow, iColCount)) > ""
        iColCount = iColCount + 1
    Wend

    Dim iRow As Integer
    iRow = iDataStartRow

    While Cells(iRow, 1) > ""
        sXML = sXML & "<" & NodeName & " type=" & Q & AtributName & Q & " id=" & Q & iRow & Q & ">"

        For icol = 1 To iColCount - 1
           sXML = sXML & "<" & Trim$(Cells(iCaptionRow, icol)) & ">"
           sXML = sXML & Trim$(Cells(iRow, icol))
           sXML = sXML & "</" & Trim$(Cells(iCaptionRow, icol)) & ">"
        Next

        sXML = sXML & "</" & NodeName & ">"
        iRow = iRow + 1
    Wend
    sXML = sXML & "</root>"

    Dim nDestFile As Integer, sText As String

    ''Close any open text files
    Close

    ''Get the number of the next free text file
    nDestFile = FreeFile

    ''Write the entire file to sText
    Open sOutputFileName For Output As #nDestFile
    Print #nDestFile, sXML
    Close

    Application.ScreenUpdating = True


End Sub

Sub ExcelToXml()
    Dim FileName As String
    FileName = InputBox("Dateinamen eingeben:")
    Call MakeXML(1, 2, ActiveWorkbook.Path & "\" & FileName & ".xml")
End Sub

我这里遇到的问题发生在大约 2000 行的文件中（也取决于列数）：Excel 冻结，我必须将其关闭。我猜可能是内存问题。我怎样才能让它更稳定？

谢谢！

答案1

我使用了相同的代码，它确实可以工作，但它确实会长时间锁定 CPU。Excel 仍在运行，但由于 VBA 使用单线程，因此它会冻结用户界面。

我已将其调整为直接转储到文件流，而不是将其保存在内存中并在最后写入所有内容，请尝试用MakeXML此替换您的函数。您还可以在写入文件时监视它，以查看它是否确实崩溃，并希望它运行得更快。如果有任何问题，请告诉我，我可以调整代码。

Sub MakeXML(iCaptionRow As Integer, iDataStartRow As Integer, sOutputFileName As String)
    Dim Q As String
    Dim NodeName As String
    Dim AtributName As String
    Dim fso As Object
    Set fso = CreateObject("Scripting.FileSystemObject")
    Dim oFile As Object


    Set oFile = fso.CreateTextFile(sOutputFileName)

    Application.ScreenUpdating = False

    Q = Chr$(34)

    oFile.Write "<?xml version=" & Q & "1.0" & Q & " encoding=" & Q & "UTF-8" & Q & "?>"
    oFile.Write "<root>"

    NodeName = "node"
    AtributName = "test"

    ''--determine count of columns
    Dim iColCount As Integer
    iColCount = 1
    While Trim$(Cells(iCaptionRow, iColCount)) > ""
        iColCount = iColCount + 1
    Wend

    Dim iRow As Integer
    iRow = iDataStartRow

    While Cells(iRow, 1) > ""
        oFile.Write "<" & NodeName & " type=" & Q & AtributName & Q & " id=" & Q & iRow & Q & ">"

        For icol = 1 To iColCount - 1
           oFile.Write "<" & Trim$(Cells(iCaptionRow, icol)) & ">"
           oFile.Write Trim$(Cells(iRow, icol))
           oFile.Write "</" & Trim$(Cells(iCaptionRow, icol)) & ">"
        Next

        oFile.Write "</" & NodeName & ">"
        iRow = iRow + 1
    Wend
    oFile.Write "</root>"


    oFile.Close

    Application.ScreenUpdating = True


End Sub

相关内容