Question

我正在尝试为QuickBooks导出做一些数据格式化，一步很慢。我有一张名为“输出”的表格，其中每个条目都以所需的格式排列，但我只希望在另一张名为“地图”的表格中使用完全填充的表格。

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

我的脚本快速填充数组，但填充单元格需要很长时间。我使用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

感谢所有帮助人员！

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

3 个答案: