## Find the closest total or exact total

YasserKhalil
PlatinumLounger
Posts: 4851
Joined: 31 Aug 2016, 09:02

### Find the closest total or exact total

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
Posts: 77254
Joined: 16 Jan 2010, 00:14
Status: Microsoft MVP
Location: Wageningen, The Netherlands

### Re: Find the closest total or exact total

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``````
Regards,
Hans

YasserKhalil
PlatinumLounger
Posts: 4851
Joined: 31 Aug 2016, 09:02

### Re: Find the closest total or exact total

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