Excel vba xml解析性能答案

【问题标题】：Excel vba xml parsing performanceExcel vba xml解析性能
【发布时间】：2017-04-20 13:30:22
【问题描述】：

我正在处理在 excel 中获取一些输入数据，将其解析为 xml 并使用它来运行 SQL 存储过程，但我在 xml 解析时遇到了性能问题。输入表如下所示：

Dates_|_Name1_Name2_Name3_..._NameX
Date1 |
Date2 |
. . . |
Date1Y|

我有一些代码可以循环每个单元格并将数据解析为 xml 字符串，但即使对于大约 300 x 300 的网格，执行也需要大约五分钟的时间，我正在寻找使用数据可能有几千列长的集合。我尝试了几件事来帮助加快速度，例如将数据读入 Variant 然后迭代或排除 DoEvents 但我无法加快速度。这是问题所在：

Dim lastRow As Long
lRows = (oWorkSheet.Cells(Rows.Count, 1).End(xlUp).Row)
Dim lastColumn As Long
lCols = (oWorkSheet.Cells(1, Columns.Count).End(xlToLeft).Column)
Dim sheet As Variant
With Sheets(sName)
  sheet = .Range(.Cells(1, 1), .Cells(lRows, lCols))
End With
ReDim nameCols(lCols) As String

...

resultxml = "<DataSet>"
For i = 2 To rows
    resultxml = resultxml & "<DateRow>"

    For j = 1 To cols
        If Trim(sheet(i, j)) <> "" Then
            lResult = "<" & nameCols(j) & ">"
            rResult = "</" & nameCols(j) & ">"
            tmpValue = Trim(sheet(i, j))
            If IsDate(tmpValue) And Not IsNumeric(tmpValue) Then
                If Len(tmpValue) >= 8 Then
                    tmpValue = Format(tmpValue, "yyyy-mm-dd")
                End If
            End If
            resultxml = resultxml & lResult & tmpValue & rResult
            DoEvents
        End If
    Next j
    resultxml = resultxml & "</DateRow>"
Next i

resultxml = resultxml & "</DataSet>"

任何关于缩短运行时间的建议将不胜感激。

【问题讨论】：

为什么DoEvents 在你的j 循环中？你能试着把它拿出来吗？
只是为了不让excel在方法运行的时候挂掉，我确实试过把它拿出来，但没看出有什么区别。
excel中的某些输入数据是否具有完全相同或相似的数据类型？
通过在一个循环中将片段连接在一起来构建大字符串可能会很慢。尝试（例如）codereview.stackexchange.com/questions/67596/… 构建您的字符串。
您的数据是否总是以第一列的日期开头，然后是其他类型的数据？就像学生考勤表一样？

标签： sql-server xml vba excel

【解决方案1】：

考虑使用MSXML，这是一个全面的 W3C 兼容 XML API 库，您可以使用它来使用 DOM 方法（createElement、appendChild、setAttribute）而不是连接文本字符串来构建 XML。 XML 不完全是一个文本文件，而是一个具有编码和树结构的标记文件。 Excel 通过引用或后期绑定配备了 MSXML COM 对象，并且可以从 Excel 数据迭代地构建树，如下所示。

有 300 行 x 12 列的随机日期，下面甚至不需要一分钟（点击宏后的字面意思是几秒钟），它甚至使用嵌入式 XSLT 样式表打印带有换行和缩进的漂亮原始输出（如果你不漂亮的打印，MSXML 将文档输出为一条长而连续的线）。

输入

VBA （当然要与实际数据对齐）

Sub xmlExport()
On Error GoTo ErrHandle
    ' VBA REFERENCE MSXML, v6.0 '
    Dim doc As New MSXML2.DOMDocument60, xslDoc As New MSXML2.DOMDocument60, newDoc As New MSXML2.DOMDocument60
    Dim root As IXMLDOMElement, dataNode As IXMLDOMElement, datesNode As IXMLDOMElement, namesNode As IXMLDOMElement
    Dim i As Long, j As Long
    Dim tmpValue As Variant

    ' DECLARE XML DOC OBJECT '
    Set root = doc.createElement("DataSet")
    doc.appendChild root

    ' ITERATE THROUGH ROWS '
    For i = 2 To Sheets(1).UsedRange.Rows.Count

        ' DATA ROW NODE '
        Set dataNode = doc.createElement("DataRow")
        root.appendChild dataNode

        ' DATES NODE '
        Set datesNode = doc.createElement("Dates")
        datesNode.Text = Sheets(1).Range("A" & i)
        dataNode.appendChild datesNode

        ' NAMES NODE '
        For j = 1 To 12
            tmpValue = Sheets(1).Cells(i, j + 1)
            If IsDate(tmpValue) And Not IsNumeric(tmpValue) Then
                Set namesNode = doc.createElement("Name" & j)
                namesNode.Text = Format(tmpValue, "yyyy-mm-dd")
                dataNode.appendChild namesNode
            End If
        Next j

    Next i

    ' PRETTY PRINT RAW OUTPUT '
    xslDoc.LoadXML "<?xml version=" & Chr(34) & "1.0" & Chr(34) & "?>" _
            & "<xsl:stylesheet version=" & Chr(34) & "1.0" & Chr(34) _
            & "                xmlns:xsl=" & Chr(34) & "http://www.w3.org/1999/XSL/Transform" & Chr(34) & ">" _
            & "<xsl:strip-space elements=" & Chr(34) & "*" & Chr(34) & " />" _
            & "<xsl:output method=" & Chr(34) & "xml" & Chr(34) & " indent=" & Chr(34) & "yes" & Chr(34) & "" _
            & "            encoding=" & Chr(34) & "UTF-8" & Chr(34) & "/>" _
            & " <xsl:template match=" & Chr(34) & "node() | @*" & Chr(34) & ">" _
            & "  <xsl:copy>" _
            & "   <xsl:apply-templates select=" & Chr(34) & "node() | @*" & Chr(34) & " />" _
            & "  </xsl:copy>" _
            & " </xsl:template>" _
            & "</xsl:stylesheet>"

    xslDoc.async = False
    doc.transformNodeToObject xslDoc, newDoc
    newDoc.Save ActiveWorkbook.Path & "\Output.xml"

    MsgBox "Successfully exported Excel data to XML!", vbInformation
    Exit Sub

ErrHandle:
    MsgBox Err.Number & " - " & Err.Description, vbCritical
    Exit Sub

End Sub

输出

<?xml version="1.0" encoding="UTF-8"?>
<DataSet>
    <DataRow>
        <Dates>Date1</Dates>
        <Name1>2016-04-23</Name1>
        <Name2>2016-09-22</Name2>
        <Name3>2016-09-23</Name3>
        <Name4>2016-09-24</Name4>
        <Name5>2016-10-31</Name5>
        <Name6>2016-09-26</Name6>
        <Name7>2016-09-27</Name7>
        <Name8>2016-09-28</Name8>
        <Name9>2016-09-29</Name9>
        <Name10>2016-09-30</Name10>
        <Name11>2016-10-01</Name11>
        <Name12>2016-10-02</Name12>
    </DataRow>
    <DataRow>
        <Dates>Date2</Dates>
        <Name1>2016-06-27</Name1>
        <Name2>2016-08-14</Name2>
        <Name3>2016-07-08</Name3>
        <Name4>2016-08-22</Name4>
        <Name5>2016-11-03</Name5>
        <Name6>2016-07-28</Name6>
        <Name7>2016-08-23</Name7>
        <Name8>2016-11-01</Name8>
        <Name9>2016-11-01</Name9>
        <Name10>2016-08-11</Name10>
        <Name11>2016-08-18</Name11>
        <Name12>2016-09-23</Name12>
    </DataRow>
    ...

【讨论】：

【解决方案2】：

我想将我用于Turn Excel range into VBA string 的 Psuedo-String Builder 与 Parfait 的 MSXML 实现进行比较，以将范围输出到 xml。我修改了 Parfait 的代码，添加了一个计时器并允许使用非日期值。

数据有一个标题行和 300 行乘 300 列（90,000 个单元格）。尽管 String Builder 的速度快了大约 400%，但我仍然会使用 Parfait 的 MSXML 方法。作为一个行业标准，它已经有据可查。

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) = "<DataSet>" & vbCrLf
    index = index + 11

    For x = 2 To UBound(data, 1)

        Mid(result, index, 11) = "<DataRow>" & 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) = "</DataRow>" & vbCrLf
        index = index + 12
    Next
    Mid(result, index, 12) = "</DataSet>" & 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) = "</" & DataArray(1, y) & ">" & vbCrLf
    Next
    getHeaderArray = Headers
End Function

【讨论】：

小心使用这种方法，因为记事本的默认编码是 ANSI 而不是 XML 的默认 UTF-8。特殊符号、实体、字符可能会丢失。同样，由于其标记规则，不应将 XML 视为严格的文本文件。此外，您的示例在元素名称中包含空格、无效规则、呈现格式不正确的 XML。
@Parfait Notepad 只是用来打开文本文件而不是写它。除此之外，我的示例只是为了演示字符串生成器模式。
@Parfait 您可以通过使用数组而不是访问每个单元格的值来优化您的代码。它与我们使用的小数据集没有太大区别，但 OP 最终数据集将是 "several thousand columns long"。另一方面，我知道你只是在展示MSXML2 的有效性，优化它并不是你的责任。
感谢您的建议，我会考虑将 MSXML 打包到用户机器上，以便过渡到那个，但字符串生成器模式暂时可以使用。