Find the closest total or exact total

[YasserKhalil]

Hello everyone
I have this code that is supposed to return the exact total (the numbers related to the desired total). The code is supposed to work on both cases (exact total or close total). It works well with the exact total but not with the closest total.
Try changing the number to 45 and it works well but with 46, I got (no combinations)

Code: Select all

Sub TestFindCombination()
    Dim numbers As Variant
    Dim dTotal As Double
    
    numbers = Array(3, 6, 5, 3, 1, 10, 20)
    dTotal = 46
    FindCombination numbers, dTotal, False, True
    
'    dTotal = 7
'    FindCombination numbers, dTotal, True, False
'
'    dTotal = 10
'    FindCombination numbers, dTotal, True, False
End Sub

Public Sub FindCombination(numbers As Variant, dTotal As Double, Optional closest As Boolean = False, Optional firstOnly As Boolean = True, Optional maxCombinations As Integer = 100)
    Dim output() As Variant
    ReDim output(UBound(numbers))
    Dim count As Integer
    count = 0
    Dim closest_sum(0) As Double
    closest_sum(0) = 1E+308 ' Initialize closest_sum with a large positive value
    Dim closest_combination() As Variant
    ReDim closest_combination(UBound(numbers))
    RecursiveCombo numbers, output, 0, UBound(numbers), dTotal, closest, closest_sum, closest_combination, count, firstOnly
    If closest And Not firstOnly And count = 0 Then
        PrintCombination numbers, closest_combination
    End If
    If count = 0 Then Debug.Print "No combination of the given numbers adds up to " & dTotal
End Sub

Private Sub RecursiveCombo(numbers As Variant, output() As Variant, iStart As Integer, iEnd As Integer, dTotal As Double, closest As Boolean, closest_sum() As Double, closest_combination() As Variant, ByRef count As Integer, firstOnly As Boolean)
    Dim i As Integer
    Dim Sum As Double
    Dim j As Long
    
    For i = 1 To 2 ^ (iEnd - iStart + 1) - 1
        ' Convert i to binary and use it to set the elements of output
        For j = LBound(output) To UBound(output)
            output(j) = ((i \ (2 ^ (j - iStart))) Mod 2) = 1
        Next j
        
        Sum = SumSelected(numbers, output)
        If Abs(Sum - dTotal) < 0.00000001 Then
            PrintCombination numbers, output
            count = count + 1 ' Increment count when a combination is found
            If firstOnly Then Exit Sub ' Exit loop if we only want the first combination
        ElseIf closest And Abs(Sum - dTotal) < Abs(closest_sum(0) - dTotal) And Sum <= dTotal Then
            closest_sum(0) = Sum
            For j = LBound(output) To UBound(output)
                closest_combination(j) = output(j)
            Next j
        End If
    Next i
    
    If closest And Not firstOnly And count = 0 Then
        PrintCombination numbers, closest_combination
    End If
End Sub

Private Function SumSelected(numbers As Variant, selected() As Variant) As Double
    Dim i As Integer
    Dim Sum As Double
    For i = LBound(numbers) To UBound(numbers)
        If selected(i) Then Sum = Sum + numbers(i)
    Next i
    SumSelected = Sum
End Function

Private Sub PrintCombination(numbers As Variant, selected() As Variant)
    Dim i As Integer
    For i = LBound(numbers) To UBound(numbers)
        If selected(i) Then Debug.Print numbers(i);
    Next i
    Debug.Print ""
End Sub

I am looking for the exact total or closest total (but less than the desired total).

[HansV]

You call FindCombinations with closest = False, so it won't find an approximate solution. And the tests weren't quite correct.

Code: Select all

Sub TestFindCombination()
    Dim numbers As Variant
    Dim dTotal As Double

    numbers = Array(3, 6, 5, 3, 1, 10, 20)
    dTotal = 45
    FindCombination numbers, dTotal, False
End Sub

Public Sub FindCombination(numbers As Variant, dTotal As Double, Optional closest As Boolean = False, Optional firstOnly As Boolean = True, Optional maxCombinations As Integer = 100)
    Dim output() As Variant
    ReDim output(UBound(numbers))
    Dim count As Integer
    count = 0
    Dim closest_sum(0) As Double
    closest_sum(0) = 1E+308 ' Initialize closest_sum with a large positive value
    Dim closest_combination() As Variant
    ReDim closest_combination(UBound(numbers))
    RecursiveCombo numbers, output, 0, UBound(numbers), dTotal, closest, closest_sum, closest_combination, count, firstOnly
    If count = 0 Then
        If closest Then
            PrintCombination numbers, closest_combination
        Else
            Debug.Print "No combination of the given numbers adds up to " & dTotal
        End If
    End If
End Sub

Private Sub RecursiveCombo(numbers As Variant, output() As Variant, iStart As Integer, iEnd As Integer, dTotal As Double, closest As Boolean, closest_sum() As Double, closest_combination() As Variant, ByRef count As Integer, firstOnly As Boolean)
    Dim i As Integer
    Dim Sum As Double
    Dim j As Long

    For i = 1 To 2 ^ (iEnd - iStart + 1) - 1
        ' Convert i to binary and use it to set the elements of output
        For j = LBound(output) To UBound(output)
            output(j) = ((i \ (2 ^ (j - iStart))) Mod 2) = 1
        Next j

        Sum = SumSelected(numbers, output)
        If Abs(Sum - dTotal) < 0.00000001 Then
            PrintCombination numbers, output
            count = count + 1 ' Increment count when a combination is found
            If firstOnly Then Exit Sub ' Exit loop if we only want the first combination
        ElseIf closest And Abs(Sum - dTotal) < Abs(closest_sum(0) - dTotal) And Sum <= dTotal Then
            closest_sum(0) = Sum
            For j = LBound(output) To UBound(output)
                closest_combination(j) = output(j)
            Next j
        End If
    Next i
End Sub

Private Function SumSelected(numbers As Variant, selected() As Variant) As Double
    Dim i As Integer
    Dim Sum As Double
    For i = LBound(numbers) To UBound(numbers)
        If selected(i) Then Sum = Sum + numbers(i)
    Next i
    SumSelected = Sum
End Function

Private Sub PrintCombination(numbers As Variant, selected() As Variant)
    Dim i As Integer
    For i = LBound(numbers) To UBound(numbers)
        If selected(i) Then Debug.Print numbers(i);
    Next i
    Debug.Print ""
End Sub

[YasserKhalil]

Amazing. Thank you very much for the great support all the time.