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

在运行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）的数组，所以会在最后一行中引发Type Mismatch错误。 那么，我该如何解决这个问题呢？ 什么是我最有效的select？

我设置了我的代码来将值存储在一个数组中，只是为了方便输出，但似乎这不会用于这么多的值。 我会更好地坚持与数组，并只写我自己的转置function（即循环通过数组，并将值写入一个新的数组），或者我会更好的工作与一个不同的类，从一开始，像一个集合，如果我只是要结束循环的结果吗？

或者更好的是，无论如何，要做到这一点， 而不必再次循环值？

编辑：

我提供了一个不好的例子，因为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

这是你的代码版本，应该更快，

 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 

Answer 2

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

也就是说，有一种方法可以在固定的时间内将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