VBA转置数组长度限制的最佳解决方法？

Posted 2023-04-19

【中文标题】VBA转置数组长度限制的最佳解决方法？

【英文标题】：Best workaround for VBA Transpose array length limit?

【发布时间】：2013-11-18 19:07:50

【问题描述】：

在运行了 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)

【问题讨论】：

自己在 VBA 中转置。

另外，在 VBA 中循环非常快。从 VBA 与 Excel 交互不是。所以只要你只是在做 VBA 的东西，重新循环应该不是问题。

【参考方案1】：

计算肯定会成为这里的瓶颈，因此（正如 RBarryYoung 所说）逐项转置数组不会真正影响宏运行的速度。

也就是说，有一种方法可以在恒定时间内将二维行转换为一列（反之亦然）：

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

【讨论】：

我很确定你不会回应，但以防万一：你声明了 GetMem4 和 GetMem8，但在下面的代码中你只使用了 GetMem8。怎么样？

我在以前的版本中使用过它，只是忘记删除它。

Win64 有这个版本吗？

@NigelHeffernan 将私有声明 PtrSafe 函数

@Chel Mind 告诉我您的“在恒定时间内”转置的解决方案是否可以与脚本字典一起使用？在 GetMem8 上找不到任何相关文档。谢谢！

【参考方案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

【讨论】：

当然。谢谢。我应该让我的示例实际上需要 ReDim Preserve 步骤 - 假设我只想在满足特定条件的情况下计算值，并且我不知道我最终会得到多少个值。在这种情况下，你会建议坚持使用数组吗？

@Excelllll ，VBA 数组非常快。如果您必须这样做，那么最后只需在 VBA 中自己转置即可。即，制作另一个具有转置维度的数组并将 totalgoals 一次复制一个元素，然后将 那个 数组粘贴到 Excel 中。我在回答中添加了一个示例。