Subset sum algorithm in vba

Question

I'm trying to write an algorithm to solve a subset sum problem.

I believe I have the start of the algorithm however I want to write something that will start off with 1 set to N sets depending on the length of the array. Ideally it will end up spitting out the first result that matches.

I believe that this could be written way better since it does follow a pattern.

Any input is appreciated.

Thanks!

Antonio

Function SubnetSum()

Dim num() As Variant
Dim goal As Double
Dim result As Double

Num() = array (1,2,3,4,5,6,7,8,9,10)

goal = 45

For i = LBound(num) To UBound(num)
    If num(i) = goal Then
        MsgBox num(i) & " " & goal & " 1 Set"
        Exit Function
    End If
Next

For i = LBound(num) To UBound(num)
    For j = i + 1 To UBound(num)
        If num(i) + num(j) = goal Then
            result = num(i) + num(j)
            MsgBox result & " " & goal & " 2 Sets"
            Exit Function
        End If
    Next
Next

For i = LBound(num) To UBound(num)
    For j = i + 1 To UBound(num)
        For k = j + 1 To UBound(num)
            If num(i) + num(j) + num(k) = goal Then
                result = num(i) + num(j) + num(k)
                MsgBox result & " " & goal & " 3 Sets"
                Exit Function
            End If
        Next
    Next
Next

For i = LBound(num) To UBound(num)
    For j = i + 1 To UBound(num)
        For k = j + 1 To UBound(num)
            For l = k + 1 To UBound(num)
                If num(i) + num(j) + num(k) + num(l) = goal Then
                    result = num(i) + num(j) + num(k) + num(l)
                    MsgBox result & " " & goal & " 4 Sets"
                    Exit Function
                End If
            Next
        Next
    Next
Next

For i = LBound(num) To UBound(num)
    For j = i + 1 To UBound(num)
        For k = j + 1 To UBound(num)
            For l = k + 1 To UBound(num)
                For m = l + 1 To UBound(num)
                    If num(i) + num(j) + num(k) + num(l) + num(m) = goal Then
                        result = num(i) + num(j) + num(k) + num(l) + num(m)
                        MsgBox result & " " & goal & " 5 Sets"
                        Exit Function
                    End If
                Next
            Next
        Next
    Next
Next

MsgBox "Nothing found"

End Function

---

Edit

@Enderland Thanks for the article I found it quite amusing and I apologize as this is my first post on this website.

What I am trying to do is to solve a subset sum problem i.e. I have a goal of 9 and using the number set of [1,2,3,4,5], I want to find the most optimal way to get to 5 using the the combination of numbers in the array.

The possible solutions are [5],[5,4],[5,3,1],[4,3,2]. However, I want to get the most optimal solution which is [5].

Moreover, if my goal is to obtain 14 from [1,2,3,4,5] it would loop through all the possible addition combinations within the array of numbers and spit out the most optimal solution, which in this case is [5,4,3,2].

What my code is doing is that it loops through the array numbers with up to 5 values until it obtains the most optimal solution.

What I want to do is write a recursive loop so that it is not hard coded to only 5 possible values. Instead I want to be able to loop through the combination of numbers with N possible values based on the size of the array.

I however for one cannot think of a loop that would support that function. I'm sure its possible with a little recursion.

I guess my question would be... Is there a way to consolidate the code I have above into one complex recursive function?

Thanks!

Answer 1

I needed a similar recursive function. Here is the code.

*add your own error handling

Public Function fSubSet(arr As Variant, goal As Double, Optional arrIndices As Variant) As Boolean

    Dim i As Integer
    Dim intSumSoFar As Integer

    i = 0
    If IsMissing(arrIndices) Then
        arrIndices = Array(0)
    End If
    For i = LBound(arrIndices) To UBound(arrIndices)
        intSumSoFar = intSumSoFar + arr(arrIndices(i))
    Next
     If intSumSoFar = goal Then
        For i = LBound(arrIndices) To UBound(arrIndices)
            Debug.Print arr(arrIndices(i))
        Next
        fSubSet = True
        Exit Function
    End If
    'now we increment one piece of the array starting from the last one
    i = UBound(arrIndices)
    Do While i > -1
        If arrIndices(i) + (UBound(arrIndices) - i) < UBound(arr) Then
            arrIndices(i) = arrIndices(i) + 1
            Exit Do
        End If
        i = i - 1
    Loop
    'if we are on the first index of the indices array and it is pushed as far as it can go then reset the array and add one to it if that doesn't make it too big
    If i = -1 And UBound(arrIndices) < UBound(arr) Then
        ReDim arrIndices(UBound(arrIndices) + 1)
        For i = 0 To UBound(arrIndices)
            arrIndices(i) = i
        Next
        'we need to end this monster
    ElseIf i = -1 And UBound(arrIndices) = UBound(arr) Then
        fSubSet = False
        Exit Function
    End If

    fSubSet = fSubSet(arr, goal, arrIndices)

End Function
Public Function fTestSubSet()
    Debug.Print fSubSet(Array(1, 2, 5, 6, 11, 10), 35)
End Function

Answer 2

I think there is an error with HelloW original code. I have updated it below, the only issue I get is an "out of stack space" error when dealing with a bigger set of numbers. In order to fix that I moved it out of recursion and it worked fine.

I left it on here as recursive because it looks better.

Public Function fSubSet(arr As Variant, ByVal goal As Double, Optional arrIndices As Variant) As Boolean
    Dim i As Integer: i = 0
    Dim intSumSoFar As Long

    If IsMissing(arrIndices) Then
        arrIndices = Array(0)
    End If
    For i = LBound(arrIndices) To UBound(arrIndices)
        intSumSoFar = intSumSoFar + arr(arrIndices(i))
    Next
     If intSumSoFar = goal Then
        For i = LBound(arrIndices) To UBound(arrIndices)
            Debug.Print arr(arrIndices(i))
        Next
        fSubSet = True
        Exit Function
    End If
    
    'now we increment one piece of the array starting from the last one
    i = UBound(arrIndices)
    Do While i > -1
        If arrIndices(i) + (UBound(arrIndices) - i) < UBound(arr) Then
            arrIndices(i) = arrIndices(i) + 1
            ' ----- Added this ----------
            If i < UBound(arrIndices) Then
                For j = i To UBound(arrIndices) - 1
                    arrIndices(j + 1) = arrIndices(j) + 1
                Next
            End If
            ' ---------------------------
            Exit Do
        End If
        i = i - 1
    Loop
    
    'if we are on the first index of the indices array and it is pushed as far as it can go then reset the array and add one to it if that doesn't make it too big
    If i = -1 And UBound(arrIndices) < UBound(arr) Then
        ReDim arrIndices(UBound(arrIndices) + 1)
        For i = 0 To UBound(arrIndices)
            arrIndices(i) = i
        Next
        'we need to end this monster
    ElseIf i = -1 And UBound(arrIndices) = UBound(arr) Then
        fSubSet = False
        Exit Function
    End If
    fSubSet = fSubSet(arr, goal, arrIndices)
End Function
Public Function fTestSubSet()
    Debug.Print fSubSet(Array(1, 2, 5, 6, 11, 10), 35)
End Function