Excel vba xml parsing performance

Question

I\'m working on taking some input data in excel, parsing it to xml and using that to run a SQL stored procedure, but I\'m running into performance issue on the xml parsing. The

Answer 1

I wanted to compare the Psuedo-String Builder that I used for Turn Excel range into VBA string against Parfait's implemetaion of MSXML to ouput the range to xml. I modified Parfait's code adding a timer and allowing non-date values.

The Data had a header row and 300 rows by 300 Columns (90,000 cells). Although the String Builder was roughly 400% faster I would still use Parfait's MSXML approach. Being an industry standard, it is already well documented.

Sub XMLFromRange()
    Dim Start: Start = Timer
    Const AVGCELLLENGTH As Long = 100
    Dim LG As Long, index As Long, x As Long, y As Long
    Dim data As Variant, Headers As Variant
    Dim result As String, s As String
    data = getDataArray
    Headers = getHeaderArray(data)

    result = Space(UBound(data, 1) * UBound(data, 2) * AVGCELLLENGTH)
    index = 1
    Mid(result, index, 11) = "" & vbCrLf
    index = index + 11

    For x = 2 To UBound(data, 1)

        Mid(result, index, 11) = "" & vbCrLf
        index = index + 11
        For y = 1 To UBound(data, 2)

            LG = Len(Headers(1, y))
            Mid(result, index, LG) = Headers(1, y)
            index = index + LG

            s = RTrim(data(x, y))
            LG = Len(s)
            Mid(result, index, LG) = s
            index = index + LG

            LG = Len(Headers(2, y))
            Mid(result, index, LG) = Headers(2, y)
            index = index + LG

        Next
        Mid(result, index, 12) = "" & vbCrLf
        index = index + 12
    Next
    Mid(result, index, 12) = "" & vbCrLf
    index = index + 12

    result = Left(result, index)

    MsgBox (Timer - Start) & " Second(s)" & vbCrLf & _
    (UBound(data, 1) - 1) * UBound(data, 2) & " Data Cells", vbInformation, "Execution Time"

    Dim myFile As String
    myFile = ThisWorkbook.Path & "\demo.txt"

    Open myFile For Output As #1
    Print #1, result
    Close #1

    Shell "Notepad.exe " & myFile, vbNormalFocus
End Sub

Function getDataArray()
    With Worksheets("Sheet1")
        getDataArray = .Range(.Range("A" & .Rows.Count).End(xlUp), .Cells(1, .Columns.Count).End(xlToLeft))
    End With
End Function

Function getHeaderArray(DataArray As Variant)
    Dim y As Long
    Dim Headers() As String
    ReDim Headers(1 To 2, 1 To UBound(DataArray, 2))
    For y = 1 To UBound(DataArray, 2)
        Headers(1, y) = "<" & DataArray(1, y) & ">"
        Headers(2, y) = "" & vbCrLf
    Next
    getHeaderArray = Headers
End Function