Лучшее решение для ограничения длины массива VBA Transpose?

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 (~ 64000). Итак, как мне это решить? Каков мой самый эффективный вариант?

Я установил свой код для хранения значений в массиве только для простого вывода, но, похоже, это не будет работать для этих многих значений. Будет ли я лучше придерживаться массивов и просто написать свою собственную функцию транспонирования (т. Е. Перебрать массив и записать значения в новый массив), или мне будет лучше работать с другим классом с самого начала, например, с коллекцией , если мне все равно придется все время кончать результаты?

Или еще лучше, есть ли все это, чтобы сделать это без, чтобы снова перевернуть значения?

EDIT:

я предоставил плохой пример, потому что 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) перенос массива по входам не влияет на скорость, с которой выполняется ваш макрос.

Тем не менее, есть это способ перенести 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