VBA: Finding max value of sum among continuous numbers - vba

Question

I have a table which goes from A1 to ALL1 (1000 values), I have to find the max value of consecutive numbers for example if I had these six values:
4 37 -12 2 3 -1, the max would be 41 taken from the first two numbers. If it was
-6 -14 6 15 22 -9, it would be 43 (from 6, 15, 22).
I have to do this in VBA from randomly generated numbers (figured that part out so it's good), but can't figure out this part and then I have to return the position of the first and last value in my sequence. So please some help would be greatly appreciated as I'm not quite a VBA wizard.
Thank you :)

Answer 1

Consider the below example:
Sub Test()
Dim arrValues() As Variant
Dim dblTop As Double
Dim lngFirst As Long
Dim lngLast As Long
Dim i As Long
Dim j As Long
Dim dblSum As Double
Dim arrResult() As Variant
arrValues = Range("A1:ALL1")
dblTop = arrValues(1, 1)
lngFirst = 1
lngLast = 1
For i = 1 To 1000
dblSum = 0
For j = i To 1000
dblSum = dblSum + arrValues(1, j)
If dblSum > dblTop Then
lngFirst = i
lngLast = j
dblTop = dblSum
End If
Next
Next
Debug.Print "Max value: " & dblTop
Debug.Print "First index: " & lngFirst
Debug.Print "Last index: " & lngLast
arrResult() = Array()
For k = lngFirst To lngLast
ReDim Preserve arrResult(UBound(arrResult) + 1)
arrResult(UBound(arrResult)) = arrValues(1, k)
Next
Debug.Print "Sequence: " & Join(arrResult, " + ")
End Sub
For the set of the values e. g. as in the question
It returns the following output

Answer 2

Just to be a little different, and because I did the work before my weekend blew up, here is a function that will return a range:
Function MAXSUM(r As Range) As Range
Dim i&, j&
Dim rng As Range
Dim sm As Double
Dim ws As Worksheet
Set ws = ActiveSheet
sm = r.Item(1) + r.Item(2)
For i = 1 To r.Cells.Count - 1
For j = i + 1 To r.Cells.Count
With ws
If WorksheetFunction.Sum(.Range(r(i), r(j))) > sm Then
Set rng = .Range(r(i), r(j))
sm = WorksheetFunction.Sum(.Range(r(i), r(j)))
End If
End With
Next j
Next i
Set MAXSUM = rng
The beauty of this is:
1.It returns the range of the max sum.
2.It is not dependent on being in the first row, it can be a column, a row, or multiples of each. It will look left to right first then top to bottom of the range.
3.It can be called from vba and/or directly as a UDF in the worksheet(see below)
To call from vba:
Sub getmax()
Dim rng As Range
Dim ws As Worksheet
Set ws = ActiveSheet
Set rng = MAXSUM(ws.Range("A1 :AAL1"))
Debug.Print rng.Address 'gets the address of range
Debug.Print WorksheetFunction.Sum(rng) 'gets the sum of the range
End Sub
This just shows a few things, but because it returns a range it is possible to do anything one can do with a given range.
To call from the worksheet directly:
To get the sum:
=SUM(MAXSUM(*YourRange*))
To get the range:
First Cell:
=ADDRESS(ROW(MAXSUM(*YourRange*)),COLUMN(MAXSUM(*YourRange*)))
Last cell:
=ADDRESS(ROW(MAXSUM(*YourRange*))+ROWS(MAXSUM(*YourRange*))-1,COLUMN(MAXSUM(*YourRange*))+COLUMNS(MAXSUM(*YourRange*))-1)
Full Address:
=ADDRESS(ROW(MAXSUM(*YourRange*)),COLUMN(MAXSUM(*YourRange*)))&":"&ADDRESS(ROW(MAXSUM(*YourRange*))+ROWS(MAXSUM(*YourRange*))-1,COLUMN(MAXSUM(*YourRange*))+COLUMNS(MAXSUM(*YourRange*))-1)
Basically the formula MAXSUM(*YourRange*) works like a named range, and anything you can do with a named range you can do with this.
One note: This currently assumes that the user wants the sum of at least two numbers and therefore if the entire range is negative, or only one consecutive positive it will return the sum of the two consecutive cells that give the highest sum. To make it so it will return the highest one cell in the case of all negative or only one consecutive positive cells then remove the +1 and -1 from the beginning of the for loops.

Answer 3

This will do it:
Sub msa()
Dim j&, cur&, max&, ndx&, ndx1&, ndx2&, a: ndx = 1
a = [A1:ALL1]
For j = 1 To UBound(a, 2)
cur = cur + a(1, j)
Select Case True
Case cur > max: max = cur: ndx2 = j: ndx1 = ndx
Case cur <= 0: cur = 0: ndx = j + 1
End Select
Next
MsgBox max & vbLf & ndx1 & vbLf & ndx2
End Sub
My answer is based on Kadane's algorithm which has a time complexity of O(n), which is dramatically more efficient than the brute force O(n*n) time complexity of the other answer.
.
UPDATE
To handle the edge case of all negative numbers as well, you can use this version:
Sub msa()
Dim j&, k&, m&, n&, cur&, max&, ndx&, ndx1&, ndx2&, a: ndx = 1: m = -2 ^ 31
a = [A1].CurrentRegion.Resize(1)
For j = 1 To UBound(a, 2)
k = a(1, j)
If k > m Then m = k: n = j
cur = cur + k
Select Case True
Case cur > max: max = cur: ndx2 = j: ndx1 = ndx
Case cur <= 0: cur = 0: ndx = j + 1
End Select
Next
If max = 0 Then max = m: ndx1 = n: ndx2 = n
MsgBox max & vbLf & ndx1 & vbLf & ndx2
End Sub