Diagonal Sum in excel table via VBA code

[spgexcel]

Hello,
Hope you are all good.
I am having a trouble with a diagonal sum vba code. Not sure what wrong I am doing.
1st will explain what I am trying to do.
In the image attached herewith is a table. (A9:F13)

• Rows A10, A11, A12 should multiply with their respective curve from the curve library and sum them diagonally.
• The multiplication should occur with the correct row and column values, ensuring the diagonal sum is cumulative.

Key Requirements:​

1. Row 10: A10 * Curve(ABC, M1)
2. Row 11: A11 * Curve(CDE, M1) + A10 * Curve(CDE, M2)
3. Row 12: A12 * Curve(CDE, M1) + A11 * Curve(CDE, M2) + A10 * Curve(CDE, M3)

I am expecting a result as in 2nd table (A15:F18)

The VBA incorrectly references to $A10 in 2nd row whereas it should reference to $A10.
Formula text table is also mentioned for reference.
Output column is where diagonal sum is expected. Have color coded the output column and table cell to show what cells are summed up to get output result.

Here is my vba code.

Sub CalculateDiagonalSum()

    Dim ws As Worksheet
    Dim lastRow As Long
    Dim i As Long, j As Long
    Dim result As Double
    Dim numberValue As Double, curveValue As Double
    Dim curveRow As Range
    Dim curveColIndex As Integer
    Dim curveName As String
    Dim rowOffset As Integer
    
 
    Set ws = ThisWorkbook.Sheets("Sheet1")
    
  
    lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
    

    ws.Range("F10:F" & lastRow).ClearContents

    For i = 10 To lastRow
        result = 0
        curveName = ws.Cells(i, "B").Value
        
     
        Set curveRow = ws.Range("B4:B6").Find(What:=curveName, LookIn:=xlValues, LookAt:=xlWhole)
        
        If Not curveRow Is Nothing Then
     
            For j = 0 To i - 10
                rowOffset = i - j
                numberValue = ws.Cells(rowOffset, "A").Value
                curveColIndex = 3 + j
                
                If curveColIndex <= 5 Then
                    curveValue = ws.Cells(curveRow.Row, curveColIndex).Value
                    result = result + (numberValue * curveValue)
                End If
            Next j
        End If

        ws.Cells(i, "F").Value = result
    Next i
    
End Sub

Hoping to resolve this as this is an example table. I am trying to do away the need of creating a big table in my model and just do a vba based diagonal sum. My model has huge table.
Hope you can help me with it.



Thanks

Sumant

 

[spgexcel]

Hi @myall_blues ,

Thank you very much for your help. You code did work. The only change that I had to make was to adjust the maxarrays to equal maxoutput as it was only considering 24 rows.
and also adjusted the Lbound and ubound conditions to ensure they are within bounds

Sub CalculateDiagonalSum()
    Dim ws As Worksheet
    Dim Result As Double
    Dim lastrow As Long, i As Long, j As Long, k As Long
    Dim maxCurves As Long, maxOutput As Long, maxArrays As Long
    Dim CurveName As String
    Dim CurveArr, OutputArr
    '
    ' Set worksheet
    '
    Set ws = ThisWorkbook.Sheets("Sheet1")
    '
    ' Get last row
    '
    lastrow = ws.Cells(ws.Rows.Count, "B").End(xlUp).Row
    '
    ' Load curve library and data into arrays
    '
    CurveArr = ws.Range("C5:AB32")
    ws.Range("C35:C" & lastrow).ClearContents
    OutputArr = ws.Range("A36:B" & lastrow)
    '
    ' Get maximum dimensions of arrays - the smaller of which becomes the
    ' maximum possible diagonal sum that can be calculated.
    '
    maxCurves = UBound(CurveArr, 2) - 1
    maxOutput = UBound(OutputArr, 1)
    
    ' Ensure that the maxArrays considers the entire OutputArr range
    maxArrays = maxOutput
    '
    ' Redim the output array to accommodate the intermediate calculations
    ' Redim the curve array to get the same number of columns as the output array
    ' (minus output column)
    '
    ReDim Preserve OutputArr(1 To UBound(OutputArr, 1), 1 To UBound(CurveArr, 2) + 2)
    ReDim Preserve CurveArr(1 To UBound(CurveArr, 1), 1 To UBound(CurveArr, 2) + 2)
    For i = LBound(CurveArr, 1) To UBound(CurveArr, 1)
        For j = UBound(CurveArr, 2) - 1 To LBound(CurveArr, 2) Step -1
            CurveArr(i, j + 1) = CurveArr(i, j)
        Next j
    Next i
    '
    ' For each row of the output array
    '
    For i = LBound(OutputArr, 1) To UBound(OutputArr, 1)
        CurveName = OutputArr(i, 2)
        '
        ' For each row of the curve array
        '
        For j = LBound(CurveArr, 1) To UBound(CurveArr, 1)
            '
            ' If the curvename is found multiply by the array values
            '
            If CurveName = CurveArr(j, 1) Then
                For k = LBound(CurveArr, 2) + 2 To UBound(CurveArr, 2)
                    OutputArr(i, k) = OutputArr(i, 1) * CurveArr(j, k)
                Next k
            End If
        Next j
    Next i
    '
' Work out the diagonal sums
For i = maxOutput To LBound(OutputArr, 1) Step -1
    k = 0
    For j = LBound(OutputArr, 2) + 2 To i + 2
        If (i - k) >= LBound(OutputArr, 1) And (i - k) <= UBound(OutputArr, 1) Then ' Ensure i - k is within bounds
            If j <= UBound(OutputArr, 2) Then ' Ensure j is within bounds
                OutputArr(i, UBound(OutputArr, 2)) = OutputArr(i, UBound(OutputArr, 2)) + _
                OutputArr(i - k, j)
            End If
        End If
        k = k + 1
    Next j
Next i


    '
    ' Output to desired location
    ' First write reference data
    '
    Range("A36").Resize(UBound(OutputArr, 1), 2) = OutputArr
    '
    ' Then write last array column
    '
    For i = LBound(OutputArr, 1) To UBound(OutputArr, 1)
        Cells(i + 35, 3).Value = OutputArr(i, UBound(OutputArr, 2))
    Next i
End Sub

Thanks
Sumant

 

[myall_blues]

You’re welcome. Thanks for the feedback.