Function avKadane(ad() As Double, Optional bAsArray As Boolean = True) As Variant
' shg 2016
' VBA only
' https://en.wikipedia.org/wiki/Maximum_subarray_problem
' Returns the maximum (positive) sum of a subarray within 1D, 1-based array ad.
' If asArray is True, returns an array containing the max, and the (1-based)
' start and end indices that delimit it.
Dim i As Long
Dim dCum As Double
Dim dMax As Double
Dim iBeg As Long
Dim iBegSav As Long
Dim iEndSav As Long
dCum = ad(1)
dMax = dCum
iBeg = 1
For i = 2 To UBound(ad)
If dCum <= 0 Then
dCum = ad(i)
iBeg = i
Else
dCum = dCum + ad(i)
End If
If dCum > dMax Then
dMax = dCum
iBegSav = iBeg
iEndSav = i
End If
Next i
If bAsArray Then
avKadane = Array(dMax, iBegSav, iEndSav)
Else
avKadane = dMax
End If
End Function
Function Kadane(avd As Variant, Optional bAsArray As Boolean = False) As Variant
' shg 2016, 2017
' UDF wrapper for avKadane
' If you want the maximum negative sum of a range, use
' = -Kadane(-rng)
' If you want the maximum negative sum of a range and extended stats, use
' {= Kadane(-rng, true) * {-1,1,1}}
Kadane = avKadane(adMake1D(avd, 1), bAsArray)
End Function
Function adMake1D(V As Variant, Optional iBase As Long = 0) As Double()
' shg 2014-0917
' Returns a 1D iBase-based array of the values in v, which can be a
' column or row vector range, a 1D or 2D array, or a scalar
Dim adOut() As Double
Dim rArea As Range
Dim cell As Range
Dim nOut As Long
Dim i As Long
If IsArray(V) Then
If TypeOf V Is Range Then
ReDim adOut(iBase To V.Cells.Count - 1 + iBase)
For Each rArea In V.Areas
For Each cell In rArea.Cells
If VarType(cell.Value2) = vbDouble Then
adOut(nOut + iBase) = CDbl(cell.Value2)
nOut = nOut + 1
Else
Err.Raise CVErr(xlErrValue)
End If
Next cell
Next rArea
adMake1D = adOut
Exit Function
Else
On Error GoTo OneD
i = LBound(V, 2)
TwoD: ' it's a 2D array - must have a single row or a single column
If UBound(V, 1) - LBound(V, 1) = 0 Then ' it's a 2D row vector
ReDim adOut(iBase To UBound(V, 2) - LBound(V, 2) + iBase)
For i = LBound(V, 2) To UBound(V, 2)
Select Case VarType(V(LBound(V, 1), i))
Case vbInteger, vbLong, vbSingle, vbDouble, vbCurrency, vbDate, vbByte
adOut(nOut + iBase) = CDbl(V(LBound(V, 1), i))
Case Else
Err.Raise CVErr(xlErrValue)
End Select
nOut = nOut + 1
Next i
adMake1D = adOut
Exit Function
adMake1D = adOut
Exit Function
ElseIf UBound(V, 2) - LBound(V, 2) = 0 Then ' it's a 2D column vector
ReDim adOut(iBase To UBound(V, 1) - LBound(V, 1) + iBase)
For i = LBound(V, 1) To UBound(V, 1)
Select Case VarType(V(i, LBound(V, 2)))
Case vbInteger, vbLong, vbSingle, vbDouble, vbCurrency, vbDate, vbByte
adOut(nOut + iBase) = CDbl(V(i, LBound(V, 2)))
Case Else
Err.Raise CVErr(xlErrValue)
End Select
nOut = nOut + 1
Next i
adMake1D = adOut
Exit Function
Else ' it's really 2D -- that's bad
Err.Raise CVErr(xlErrValue)
Exit Function
End If
OneD: ' it's a 1D array
ReDim adOut(iBase To UBound(V) - LBound(V) + iBase)
For i = LBound(V, 1) To UBound(V, 1)
Select Case VarType(V(i))
Case vbInteger, vbLong, vbSingle, vbDouble, vbCurrency, vbDate, vbByte
adOut(nOut + iBase) = CDbl(V(i))
Case Else
Err.Raise CVErr(xlErrValue)
End Select
nOut = nOut + 1
Next i
adMake1D = adOut
Exit Function
End If
Else 'it's a scalar
ReDim adOut(iBase To iBase)
Select Case VarType(V)
Case vbInteger, vbLong, vbSingle, vbDouble, vbCurrency, vbDate, vbByte
adOut(iBase) = CDbl(V)
adMake1D = adOut
Case Else
Err.Raise CVErr(xlErrValue)
End Select
End If
End Function
