如何在 VBA 中创建 n 个数组

Question

我有以下代码可以完美运行并完成我需要的技巧。

但是我希望这段代码运行 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）中的值并创建 array1 并将数组插入结果列。

我想要实现的是重复此代码/循环 n 次并创建动态数量的数组，然后将这些数组的结果放入 Result 列。我不知道如何在一个循环中创建一个 array1 然后 array2 等等。

一列可能有 60k+ 行，因此我需要非常轻量级的解决方案来实现最短运行时间。

感谢您的帮助。

编辑：

添加图片

Answer 1

这假定您的日期和值始终成对出现，因此您使用的列始终是偶数。

基本上添加了另一个循环来遍历列，并在每列计算结束时，将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

Answer 2

总结结果数组

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