Excel VBA：用数组值填充单元格非常慢

Question

我正在尝试为 QuickBooks 导出进行一些数据格式化，但一步非常慢。我有一个名为“输出”的工作表，其中每个条目都以所需的格式排列，但我只希望将完全填充的条目用于另一个名为“地图”的工作表上。

到目前为止，一切都是用公式完成的，这部分工作正常。我编写了一个小脚本来遍历所有条目并将相关信息从“输出”拉到五个不同的数组中。然后它循环回这些数组并填充“地图”中相应列中的单元格。

我的脚本快速填充数组，但填充单元格需要很长时间。我使用 for 循环遍历数组，每次迭代大约需要 3 秒，当您处理数千个条目时，这是一个很长的时间。

Sub Prettify()

    Dim numbers()
    Dim catagories()
    Dim classes()
    Dim subclasses()
    Dim values()

    Dim count As Integer

    count = 2

    ' The upper bounds of the loop is a calculation of the number of entries we will access

    For i = 2 To (Sheets("Data").Cells(7, 8).Value * Sheets("Data").Cells(4, 3).Value + 2)


        If (Sheets("Output").Cells(i, 1).Value = "") Then

            ' Do Nothing

        Else

            ReDim Preserve numbers(count)
            ReDim Preserve catagories(count)
            ReDim Preserve classes(count)
            ReDim Preserve subclasses(count)
            ReDim Preserve values(count)

            count = count + 1

            numbers(count - 2) = Val((Sheets("Output").Cells(i, 1).Value))
            catagories(count - 2) = Sheets("Output").Cells(i, 2).Value

            If (Sheets("Output").Cells(i, 3).Value = 0) Then

                classes(count - 2) = Sheets("Output").Cells(i, 4).Value
                subclasses(count - 2) = ""

            Else

                classes(count - 2) = Sheets("Output").Cells(i, 3).Value
                subclasses(count - 2) = Sheets("Output").Cells(i, 4).Value

            End If

            values(count - 2) = Sheets("Output").Cells(i, 5).Value

        End If

    Next

    MsgBox (numbers(0))
    MsgBox (catagories(0))

    Sheets("Map").Activate

    '  This next part is slow

    For j = 2 To count

        Sheets("Map").Cells(j, 1).Value = numbers(j - 2)
        Sheets("Map").Cells(j, 2).Value = catagories(j - 2)
        Sheets("Map").Cells(j, 3).Value = classes(j - 2)
        Sheets("Map").Cells(j, 4).Value = subclasses(j - 2)
        Sheets("Map").Cells(j, 5).Value = values(j - 2)

    Next

End Sub

大约三年前，我在一篇帖子中遇到过类似的问题，但他们使用的修复程序不适用于我的示例。我使用消息框在不同点测试了代码，最后一个 for 循环中的五个分配步骤中的每一个都同样慢。想法？

Answer 1

我遇到了这个问题，问题是您的代码一个接一个地访问每个单元格。关闭屏幕和事件会有所帮助，但它仍然会很慢并且会因更大的数组而瘫痪。

解决方案是一次性将所有内容转储到单元格中。为此，您需要使用多维数组。这听起来很复杂，但一旦你明白了它就不会了。

您似乎也以同样的方式从工作簿中获取数据。

这是一些应该对其进行排序的代码，它看起来很简单，但它确实有效。

Dim v_Data() as variant
Dim range_to_Load as range
Dim y as long, x as long
'set a range or better still use a list object
set range_to_Load = thisworkbook.sheets("Data").Range("A1:F100")
'Load the range into a variant array.
with range_to_Load
    redim v_data(1 to .rows.count, 1 to .columns.count)
    v_data = .value
end with
' v_data now holds all in the range but as a multidimentional array
' to access it its going to be like a grid so 
v_data(row in the range, column in the range)
'Loop through the array, I'm going to covert everything to a string then
'dump it in the Map sheet you have
' you should avoid x,y as variables however this is a good use as they are coordinate values.
'lbound and ubound will loop y though everything by row as it is the first dimension in the array. 
For y = lbound(v_data) to ubound(v_data) 
    ' next we are going to do the same but for the second dimention
    For x = lbound(v_data,2) to ubound(v_data,2)
         vdata(y,x) = cstr(v_data(y,x))
    Next x
Next y
'We have done something with the array and now want to put it somewhere, we could just drop it where we got it from to do this we  would say
range_to_Load.value = v_data
' to put it else where
thisworkbook.sheets("Map").range("A1").resize(ubound(v_data), ubound(v_data,2)).value = v_data

这应该可以解决您的问题，您可以用它做很多事情。阅读多维数组，Chip Pearson 像往常一样有很多话要说，并且会有所帮助。

您可以在几秒钟内而不是几分钟内处理大量集合，因为在数组中所有操作都在内存中完成，只有当您获取数据并将其放回时才能访问工作簿，从而真正最大限度地减少运行代码所需的时间.

Answer 2

尝试在代码开头使用它

Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
ActiveSheet.DisplayPageBreaks = False

最后，添加

Application.ScreenUpdating = True
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
ActiveSheet.DisplayPageBreaks = True

现在，如果您的代码中断，您将遇到问题，因为我已将您的计算改为手动计算。所以你应该添加一个错误处理程序。如果这有点太复杂，请删除屏幕更新的所有栏

所以在顶部，还要添加

On Error GoTo ErrHandler

最后加上：

Exit Sub
ErrHandler:
    Application.ScreenUpdating = True
    Application.EnableEvents = True
    Application.Calculation = xlCalculationAutomatic
    ActiveSheet.DisplayPageBreaks = True

End Sub

我希望这会有所帮助。

Answer 3

Kamilla Whatling 建议使用多维数组、Range 对象和不同类型的细胞群来加快该过程。他们工作了，下面是最终的项目代码，它可以快速运行并同时删除不需要的条目。

Sub Prettify()

Dim values() As Variant
Dim usableRange As Range
Dim rangeSelection As String
Dim entryNumber As Long
Dim count As Long

count = 0

entryNumber = Sheets("Data").Cells(4, 3).Value * Sheets("Data").Cells(7, 8).Value

rangeSelection = "A2:E" & (entryNumber + 1)

Set usableRange = Sheets("Output").Range(rangeSelection)

For i = 1 To entryNumber

    If Sheets("Output").Cells(i, 1) = "" Then

    Else

        count = count + 1

    End If

Next

ReDim values(count, 5)
count = 0

For i = 1 To entryNumber

    If usableRange.Cells(i, 1) = "" Then

    Else

        values(count, 0) = usableRange.Cells(i, 1).Value
        values(count, 1) = usableRange.Cells(i, 2).Value

        If usableRange.Cells(i, 3).Value = 0 Then

            values(count, 2) = usableRange.Cells(i, 4).Value
            values(count, 3) = ""

        Else

            values(count, 2) = usableRange.Cells(i, 3).Value
            values(count, 3) = usableRange.Cells(i, 4).Value

        End If

        values(count, 4) = usableRange.Cells(i, 5).Value

        count = count + 1

    End If

Next

Sheets("Map").Range("A2").Resize(UBound(values), 5).Value = values

End Sub

感谢大家的帮助！