Question

我想问一下是否有人知道如何让这段代码变得更快。目前，在大数据（超过180 000行/ 39列）的情况下，使用MS Excel 2007时生成所有代码大约需要5:50小时。

我很乐意接受任何建议。

Sub TOXML()

    strChoosenFile = InputBox("Write number of file which you want generate.", "Choose sheet for generation XML")

    Worksheets("time").Cells(1, 1) = Now

    Application.ScreenUpdating = False

    Dim lngRow As Long
    Dim strInsetText$

    lngRow = 1

    RowsInSource = Worksheets(strChoosenFile).Range("A300000").End(xlUp).Row - 2
    ColumnsInSource = Worksheets(strChoosenFile).Range("DD2").End(xlToLeft).Column

    For i = 1 To RowsInSource

        strInsetText = "<R>"

        For x = 1 To ColumnsInSource

            strInsetText = strInsetText & "<S>" & Worksheets(strChoosenFile).Cells(i + 2, x).Text & "</S>"

        Next x

        strInsetText = strInsetText & "</R>"

        Worksheets(strChoosenFile & "-XML").Cells(lngRow, 1) = strInsetText

        lngRow = lngRow + 1
        strInsetText = ""

    Next i

    Worksheets("time").Cells(1, 2) = Now

    Application.ScreenUpdating = True

    MsgBox "Done: " & i - 1

End Sub

Answer 1

建议：尝试将工作表数据移动到数组：

dim ar() as variant
ar = Worksheets(strChoosenFile).Range("A1").CurrentRegion  'or any range selection method

然后使用数组元素而不是单元格。这将最大限度地减少VBA和工作表之间的交换，这是昂贵的（在性能方面）同样，您也可以加载整行而不是单元格。

Answer 2

试试这段代码。在我的机器上只需 15秒（对于180 000行/ 39列）

Sub TOXML()
    Dim strChoosenFile
    Dim lngRow As Long, RowsInSource As Long, ColumnsInSource As Long, i As Long, x As Long
    Dim strInsetText As String
    Dim arr
    Dim res() As String

    strChoosenFile = InputBox("Write number of file which you want generate.", "Choose sheet for generation XML")

    Worksheets("time").Cells(1, 1) = Now
    Application.ScreenUpdating = False

    With Worksheets(strChoosenFile)
        RowsInSource = .Range("A300000").End(xlUp).Row - 2
        ColumnsInSource = .Range("DD2").End(xlToLeft).Column
        'write all values in array
        arr = .Range(.Cells(3, 1), .Cells(RowsInSource + 2, ColumnsInSource)).Value
    End With
    'Redim array for result, note that I'm using 2D array,
    'because I want to get "Column" array, rather than "Row" array
    ReDim res(1 To RowsInSource, 1 To 1)

    For i = 1 To RowsInSource
        res(i, 1) = "<R>"
        For x = 1 To ColumnsInSource
            res(i, 1) = res(i, 1) & "<S>" & arr(i, x) & "</S>"
        Next x
        res(i, 1) = res(i, 1) & "</R>"
    Next i
    'write result of array on the sheet
    Worksheets(strChoosenFile & "-XML").Cells(1, 1).Resize(UBound(res)).Value = res
    Worksheets("time").Cells(1, 2) = Now

    Application.ScreenUpdating = True
    MsgBox "Done: " & i - 1
End Sub

此外，我不确定你为什么要硬编码.Range("A300000")和.Range("DD2")（也许你需要它），但另请阅读：How to determine last used row/column

Excel到XML：性能提升

2 个答案: