Разбор Excel в xml с использованием VBA

Question

У меня есть код 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 зависает, и мне приходится его убивать. Я предполагаю, что может быть проблема с памятью. Как я могу сделать это более стабильным?

Спасибо!

Answer 1

Я использовал тот же код, и он работает, но он очень долго блокирует процессор, работая над ним. 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