I have a following code which works perfectly and does a trick I need.

However I want this code to run for n number of times and create n arrays.

My dataset is:

My code is:

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

Code explanation: (dataset is just for visual purposes) Code calculates Value in a column (for instance column B) and creates array1 and and insert array into result column.

What I want to implement is repeat this code/loop n number of times and create dynamic number of arrays and then put a result of these arrays into Result column. I can't figure out how to create an array1 then array2 and so on within one loop.

One column might have 60k rows hence I need really light weight solution to achieve a minimum run time.

Thank you for your help.

CodePudding user response：

This assumes that your Date and Values are always in pairs and so your used columns are always even.

Basically added another loop to go over the columns and at the end of each column's calculation, add outputArr into a Collection (outputColl). I have added sample of how you can iterate the collection and the rows of each array at the end.

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

CodePudding user response：

Sum Up Resulting Arrays

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