Return the largest disjoint and contiguous subsets ranging from size 1 to L among N positive numbers

Question

I'm trying to generalize the algorithm Paul Hankin provided in Maximizing the overall sum of K disjoint and contiguous subsets of size L among N positive numbers such that the solution is not limited to each subset being exactly size L and where the goal is not to maximize the overall sum, but to return the set with the largest subsets possible.

Spelling out the details, X is a set of N positive real numbers: X={x[1],x[2],...x[N]} where x[j]>=0 for all j=1,...,N.

A contiguous subset called S[i] consists of up to L consecutive members of X starting at position n[i] and ending at position n[i]+l-1:

S[i] = {x[j] | j=n[i],n[i]+1,...,n[i]+l-1} = {x[n[i]],x[n[i]+1],...,x[n[i]+l-1]}, where l=1,...,L.

Two of such subsets S[i] and S[j] are called pairwise disjoint (non-overlapping) if they don't contain any identical members of X.

Define the summation of the members of each subset:

SUM[i] = x[n[i]]+x[n[i]+1]+...+x[n[i]+l-1]

The goal is find contiguous and disjoint (non-overlapping) subsets S[1],S[2],... of lengths ranging from 1 to L that are as large as possible and cover all N elements of X.

For example, given X = {5,6,7,100,100,7,8,5,4,4} and L = 4, the solution is S[1] = {5,6,7}, S[2] = {100, 100, 7, 8}, and S[3] = {5,4,4} such that SUM[1] = 18, SUM[2] = 215, and SUM[3] = 13. While the overall sum, no matter the subsets, will always be 246, the key is that no other subsets with lengths ranging from 1 to L will produce larger SUM[i], than those provided above.

Any help is greatly appreciated.

Answer 1

Here's a better solution:

 Sub getLargestEvents()

'Algorithm adapted from http://stackoverflow.com/questions/29268442/maximizing-the-overall-sum-of-k-disjoint-and-contiguous-subsets-of-size-l-among

    Dim N As Long 'limit of +2,147,483,647
    Dim X As Variant
    Dim i As Long
    Dim L As Integer
    Dim S As Variant
    Dim j As Integer
    Dim tempS As Variant
    Dim largestEvents As Variant
    Dim numberOfEvents As Long
    Dim sumOfM As Double
    Dim maxSUM As Double
    Dim maxI As Long
    Dim maxJ As Long

    X = Array(5, 6, 7, 100, 100, 7, 8, 5, 4, 4, 100, 100, 4, 5, 6, 7, 8)

   'N is the number of days of loss in the array X
    N = UBound(X)

    'L is the hours clause expressed in days (i.e., L = hours clause / 24)
    L = 4

   'S contains the sums of all events that contain no more than L contiguous days of loss
    ReDim S(L * N, L)

    'Debug.Print "i, j, S(i, j):"
    For i = 1 To N
        For j = 1 To L
            If i >= j Then
                S(i, j) = X(i) + S(i - 1, j - 1)
                'Debug.Print i & ", " & j & ", " & S(i, j)
            End If
        Next j
    Next i

    tempS = S
    ReDim largestEvents(N, 3)

    Do While WorksheetFunction.SUM(S) > 0

        maxSUM = 0
        numberOfEvents = numberOfEvents + 1

        'Determine max value in current array
        For i = 1 To N
            For j = 1 To L
                If i >= j Then
                    If tempS(i, j) > maxSUM Then 'tempS(i, j) > maxSUM Then
                        maxSUM = S(i, j)
                        maxI = i
                        maxJ = j
                    End If
                    'Debug.Print "tempS(" & i & ", " & j & ") = " & tempS(i, j)
                End If
            Next j
        Next i

        sumOfM = sumOfM + maxSUM
        'Store max value

        largestEvents(numberOfEvents, 1) = maxI
        largestEvents(numberOfEvents, 2) = maxJ
        largestEvents(numberOfEvents, 3) = maxSUM

        'Debug.Print "maxI: " & maxI & ", maxJ: " & maxJ & ", maxSUM: " & maxSUM

        'Remove values that can no longer apply
        For i = 1 To N
            For j = 1 To L
                If i >= j Then
                    If (maxI - maxJ < i And i <= maxI) Or (maxI < i And i - j < maxI) Then
                        tempS(i, j) = 0
                        'Debug.Print "tempS(" & i & ", " & j & ") = " & tempS(i, j) & " <- removed"
                    End If
                End If
            Next j
        Next i

        S = tempS

    Loop

    Debug.Print "Start Date, Length, Amount"

    For i = 1 To numberOfEvents
        Debug.Print "start date: " & largestEvents(i, 1) - largestEvents(i, 2) + 1 & ", length: " & largestEvents(i, 2) & ", amount: " & largestEvents(i, 3)
    Next i

End Sub

Function getUserSelectedRange(description As String) As Range
'Code adapted from
'http://stackoverflow.com/questions/22812235/using-vba-to-prompt-user-to-select-cells-possibly-on-different-sheet

    Set getUserSelectedRange = Application.InputBox("Select a range of " + description, "Obtain Range Object", Type:=8)

End Function