我有以下代碼，它可以完美運行并完成我需要的技巧。
但是我希望這段代碼運行 n 次并創建 n 個陣列。
我的資料集是：
我的代碼是：
Option Explicit
Private Sub Test()
Const startRow As Long = 2
Const valueCol As Long = 2
Const outputCol As Long = 4
Dim ws As Worksheet
Set ws = ThisWorkbook.Worksheets("Sheet1")
Dim lastRow As Long
lastRow = ws.Cells(ws.Rows.Count, valueCol).End(xlUp).Row
Dim inputArr As Variant
inputArr = ws.Range(ws.Cells(startRow, valueCol), ws.Cells(lastRow, valueCol)).Value
Dim outputSize As Long
outputSize = ((UBound(inputArr, 1) - 1) * UBound(inputArr, 1)) / 2
Dim outputIndex As Long
Dim outputArr As Variant
ReDim outputArr(1 To outputSize, 1 To 1) As Variant
Dim i As Long
Dim n As Long
Dim currFirst As Long
Dim currLowest As Long
For i = 2 To UBound(inputArr, 1)
currFirst = inputArr(i, 1)
currLowest = currFirst - inputArr(i - 1, 1)
For n = i - 1 To 1 Step -1
Dim testLowest As Long
testLowest = currFirst - inputArr(n, 1)
If testLowest < currLowest Then currLowest = testLowest
outputIndex = outputIndex 1
outputArr(outputIndex, 1) = currLowest
Next n
Next i
ws.Cells(startRow, outputCol).Resize(UBound(outputArr, 1)).Value = outputArr
End Sub
代碼說明：（資料集僅用于視覺目的）代碼計算列中的值（例如列 B）并創建陣列 1 并將陣列插入結果列。
我想要實作的是重復此代碼/回圈 n 次并創建動態數量的陣列，然后將這些陣列的結果放入 Result 列中。我不知道如何在一個回圈中創建一個 array1 然后 array2 等等。
一列可能有 60k 行，因此我需要非常輕量級的解決方案來實作最短的運行時間。
感謝您的幫助。
編輯：
添加圖片
uj5u.com熱心網友回復：
這假設您的日期和值始終成對，因此您使用的列始終是偶數。
基本上添加了另一個回圈來遍歷列，并在每列的計算結束時添加outputArr到Collection( outputColl) 中。我已經添加了如何在最后迭代每個陣列的集合和行的示例。
Option Explicit
Private Sub Test()
Const startRow As Long = 2
Const firstValueCol As Long = 2
Dim ws As Worksheet
Set ws = ThisWorkbook.Worksheets("Sheet1")
Dim lastRow As Long
Dim lastCol As Long
With ws
lastRow = .Cells(.Rows.Count, firstValueCol).End(xlUp).Row
lastCol = .Cells(startRow, .Columns.Count).End(xlToLeft).Column
End With
Dim outputSize As Long
outputSize = ((lastRow - startRow) * (lastRow - startRow 1)) / 2
Dim outputArr As Variant
ReDim outputArr(1 To outputSize, 1 To 1) As Variant
Dim outputColl As Collection
Set outputColl = New Collection
Dim x As Long
Dim i As Long
Dim n As Long
For x = firstValueCol To lastCol Step 2
Dim inputArr As Variant
inputArr = ws.Range(ws.Cells(startRow, x), ws.Cells(lastRow, x)).Value
Dim outputIndex As Long
outputIndex = 0
For i = 2 To UBound(inputArr, 1)
Dim currFirst As Long
Dim currLowest As Long
currFirst = inputArr(i, 1)
currLowest = currFirst - inputArr(i - 1, 1)
For n = i - 1 To 1 Step -1
Dim testLowest As Long
testLowest = currFirst - inputArr(n, 1)
If testLowest < currLowest Then currLowest = testLowest
outputIndex = outputIndex 1
outputArr(outputIndex, 1) = currLowest
Next n
Next i
outputColl.Add outputArr
Next x
'Loop through your collection
For x = 1 To outputColl.Count
'loop through the rows in the array
For i = 1 To UBound(outputColl(x), 1)
'Do your math here
Debug.Print outputColl(x)(i, 1)
Next i
Next x
'Dim outputCol As Long
'outputCol = lastCol 1
'ws.Cells(startRow, outputCol).Resize(UBound(outputArr, 1)).Value = outputArr
End Sub
uj5u.com熱心網友回復：
總結結果陣列
Option Explicit
' 1448 rows in source will generate 1047629 rows in destination,
' which takes about 6-7 seconds for 10 columns.
Sub WriteTricky()
' Needs 'GetTricky' and 'SumUpTwoArrays'.
Dim dTime As Double: dTime = Timer ' time measuring
' Source
Const sName As String = "Sheet1"
Const sColsList As String = "B,D,F,H,J,L,N,P,R,T"
Const slrCol As String = "B" ' Last Row Column
Const sfRow As Long = 2 ' First Row
' Destination
Const dName As String = "Sheet1"
Const dFirstCellAddress As String = "V2"
' Workbook
Dim wb As Workbook: Set wb = ThisWorkbook
' Create a reference to the source last (one-column) range.
Dim sws As Worksheet: Set sws = wb.Worksheets(sName)
Dim slRow As Long: slRow = sws.Cells(sws.Rows.Count, slrCol).End(xlUp).Row
Dim srCount As Long: srCount = slRow - sfRow 1
If srCount < 2 Then Exit Sub
Dim drCount As Long: drCount = (srCount - 1) * srCount / 2
If sws.Rows.Count - drCount - sfRow 1 < 0 Then Exit Sub ' will not fit
Dim slrcrg As Range: Set slrcrg = sws.Cells(sfRow, slrCol).Resize(srCount)
' Write the 'tricky' values to the destination array.
Dim sCols() As String: sCols = Split(sColsList, ",")
Dim nUpper As Long: nUpper = UBound(sCols)
Dim dData As Variant
Dim aData As Variant
Dim scrg As Range
Dim n As Long
For n = 0 To UBound(sCols)
Set scrg = slrcrg.EntireRow.Columns(sCols(n))
If n > 0 Then
aData = GetTricky(scrg)
SumUpTwoArrays dData, aData
Else
dData = GetTricky(scrg)
End If
Next n
' Write values from destination array to the destination (one-column) range.
Dim dws As Worksheet: Set dws = wb.Worksheets(dName)
Dim dfcell As Range: Set dfcell = dws.Range(dFirstCellAddress)
Dim dcrg As Range: Set dcrg = dfcell.Resize(UBound(dData))
dcrg.Value = dData
Debug.Print Timer - dTime ' time measuring
End Sub
' This is Raymond Wu's logic transferred to a function.
Function GetTricky( _
ColumnRange As Range) _
As Variant
If ColumnRange Is Nothing Then Exit Function
Dim sData As Variant
Dim srCount As Long
With ColumnRange.Columns(1)
srCount = .Rows.Count
If srCount = 1 Then Exit Function
sData = .Value
End With
Dim drCount As Long: drCount = (srCount - 1) * srCount / 2
Dim dData As Variant: ReDim dData(1 To drCount, 1 To 1)
Dim sr As Long
Dim sn As Long
Dim currFirst As Long
Dim currLowest As Long
Dim testLowest As Long
Dim dr As Long
For sr = 2 To srCount
currFirst = sData(sr, 1)
currLowest = currFirst - sData(sr - 1, 1)
For sn = sr - 1 To 1 Step -1
testLowest = currFirst - sData(sn, 1)
If testLowest < currLowest Then currLowest = testLowest
dr = dr 1
dData(dr, 1) = currLowest
Next sn
Next sr
GetTricky = dData
End Function
Sub SumUpTwoArrays( _
ByRef SumData As Variant, _
ByVal AddData As Variant) ' note 'ByRef' i.e. 'SumData' will be modified
Dim aValue As Variant
Dim r As Long
For r = 1 To UBound(AddData)
aValue = AddData(r, 1)
If IsNumeric(aValue) Then
If aValue <> 0 Then
SumData(r, 1) = SumData(r, 1) aValue
End If
End If
Next r
End Sub
轉載請註明出處，本文鏈接：https://www.uj5u.com/ruanti/374120.html