Question

在运行100,000次迭代的模拟后，我尝试将每次迭代的值转储到一列中。以下是代码的要点：

Sub test()
Application.ScreenUpdating = False
Dim totalgoals() As Variant, ko As Worksheet, out As Worksheet, iter As Long
Set ko = Sheets("KO Sim")
Set out = Sheets("Monte Carlo")
iter = out.Range("P2").Value
For i = 1 To iter
    ko.Calculate
    If i = 1 Then
        ReDim totalgoals(1 To 1, 1 To 1) As Variant
        totalgoals(1, 1) = ko.Range("F23").Value
    Else
        ReDim Preserve totalgoals(1 To 1, 1 To i) As Variant
        totalgoals(1, i) = ko.Range("F23").Value
    End If
Next i
out.Range("U1:U" & iter) = Application.WorksheetFunction.Transpose(totalgoals)
Application.ScreenUpdating = True
End Sub

这会在倒数第二行引发类型不匹配错误，因为Transpose只能处理长度最大为2 ^ 16（~64,000）的数组。那么，我应该如何解决这个问题呢？什么是我最有效的选择？

我设置了我的代码来将值存储在一个数组中，只是为了方便输出，但似乎不适用于这么多的值。我会更好地坚持使用数组并编写我自己的转置函数（即循环遍历数组并将值写入新数组），或者我最好从一开始就使用不同的类，比如集合，如果我最终还是要完成结果呢？

或者更好的是，无论如何，如果没有不得不再次遍历这些值，

修改

我提供了一个不好的例子，因为ReDim Preserve调用是不必要的。因此，请考虑以下内容，而不是必要的地方。

ReDim totalgoals(1 To 1, 1 To 1) As Variant For i = 1 To iter ko.Calculate If ko.Range("F23") > 100 Then If totalgoals(1, 1) = Empty Then totalgoals(1, 1) = ko.Range("F23").Value Else ReDim Preserve totalgoals(1 To 1, 1 To UBound(totalgoals, 2) + 1) As Variant totalgoals(1, UBound(totalgoals, 2)) = ko.Range("F23").Value End If End If Next i out.Range("U1").Resize(UBound(totalgoals, 2),1) = Application.WorksheetFunction.Transpose(totalgoals)

Answer 1

计算肯定会成为这里的瓶颈，所以（如RBarryYoung所说）逐个输入数组并不会真正影响宏运行的速度。

那就是说，是一种在固定时间内将2D行转换为列（反之亦然）的方法：

Private Declare Function VarPtrArray Lib "msvbvm60" Alias _
    "VarPtr" (ByRef Var() As Any) As Long
Private Declare Sub GetMem4 Lib "msvbvm60.dll" (src As Any, dest As Any)
Private Declare Sub GetMem8 Lib "msvbvm60.dll" (src As Any, dest As Any)

Sub test()
    Dim totalgoals() As Single
    Dim f As Single
    Dim i As Long, iter As Long

    'dimension totalgoals() with as many cells as we
    'could possibly need, then cut out the excess
    iter = 100000
    ReDim totalgoals(1 To 1, 1 To iter)
    For iter = iter To 1 Step -1
        f = Rnd
        If f > 0.2 Then
            i = i + 1
            totalgoals(1, i) = f
        End If
    Next iter
    ReDim Preserve totalgoals(1 To 1, 1 To i)

    'transpose by swapping array bounds in memory
    Dim u As Currency
    GetMem8 ByVal VarPtrArray(totalgoals) + 16, u
    GetMem8 ByVal VarPtrArray(totalgoals) + 24, _
            ByVal VarPtrArray(totalgoals) + 16
    GetMem8 u, ByVal VarPtrArray(totalgoals) + 24
End Sub

Answer 2

以下是您的代码版本，应该可以更快地运行：

Sub test()
Application.ScreenUpdating = False
Dim totalgoals() As Variant, ko As Worksheet, out As Worksheet, iter As Long
Set ko = Sheets("KO Sim")
Set out = Sheets("Monte Carlo")
iter = out.Range("P2").Value

' ReDim it completely first, already transposed:
ReDim totalgoals(1 To iter, 1 To 1) As Variant

For i = 1 To iter
    ko.Calculate
    totalgoals(i, 1) = ko.Range("F23").Value
Next i
out.Range("U1:U" & iter) = totalgoals
Application.ScreenUpdating = True
End Sub

这是一个保留条件ReDims的版本，但最后手动转换数组：

Sub test()
Application.ScreenUpdating = False
Dim totalgoals() As Variant, ko As Worksheet, out As Worksheet, iter As Long
Set ko = Sheets("KO Sim")
Set out = Sheets("Monte Carlo")
iter = out.Range("P2").Value
For i = 1 To iter
    ko.Calculate
    If i = 1 Then
        ReDim totalgoals(1 To 1, 1 To 1) As Variant
        totalgoals(1, 1) = ko.Range("F23").Value
    Else
        ReDim Preserve totalgoals(1 To 1, 1 To i) As Variant
        totalgoals(1, i) = ko.Range("F23").Value
    End If
Next i
' manually transpose it
Dim trans() As Variant
ReDim trans(1 to UBound(totalgoals), 1 to 1)
For i = 1 to UBound(totalgoals)
    trans(i, 1) = totalgoals(1, i)
Next i
out.Range("U1:U" & iter) = trans
Application.ScreenUpdating = True
End Sub

VBA Transpose阵列长度限制的最佳解决方法？

2 个答案: