I've got the next Sixth Sense's code that Norie helped me to modificate. It works great.

The code returns the sum combinations to get an exact value.

Here it is my request:

If the code doesnt get a combination to equal my value, I would like the code find the combination for the next minimum value.

Example: (with my example worksheet)

If I enter in B2 the number 6, the code will not display any results, cause there is not exist a combination sum in my list to get that value.

So, the code automatically should reduce the value of B2 in 0.01 until get a sum combination to reach that amount.

I mean, if there isnt any combination for 6, it should look for 5.99. If it doesnt exist for 5.99, it should look for 5.98. If it doesnt exist for 5.98, it should look for 5.97; and so on, until get a combination.

rgds,

Arnolf

**If I enter in B2 number 6, I need the next results:**

combin.xls | ||||||||||||
---|---|---|---|---|---|---|---|---|---|---|---|---|

A | B | C | D | E | F | G | H | I | J | |||

1 | list | Desired sum | Sum | possible combination | ||||||||

2 | 1 | 5.97 | 5.97 | 7.93 | -1.96 | |||||||

3 | 1.96 | 5.97 | 1.96 | 4.01 | ||||||||

4 | 3 | |||||||||||

5 | 4.01 | |||||||||||

6 | 7.93 | |||||||||||

7 | -1.96 | |||||||||||

8 | ||||||||||||

9 | ||||||||||||

10 | ||||||||||||

11 | ||||||||||||

12 | ||||||||||||

13 | ||||||||||||

14 | ||||||||||||

15 | ||||||||||||

Sheet2 |

Code:

```
Dim n, k, q As Double
Dim Comblist() As String
Dim b()
Dim Ans() As Variant
Private Sub Comb(j, m As Integer)
Dim tmp, X
If j > n Then
tmp = ""
For X = 1 To n
tmp = tmp & b(X)
Next X
q = q + 1
ReDim Preserve Comblist(UBound(Comblist) + 1) As String
Comblist(UBound(Comblist)) = tmp
Else
If k - m< n - j + 1 Then
b(j) = 0
Comb j + 1, m
End If
If m< k Then
b(j) = 1
Comb j + 1, m + 1
End If
End If
End Sub
Sub Sum2xxx()
Dim St, i, j, tmp, Tmp2, AnsCount, L, Res
Dim listx()
Dim nums
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
n = Range("a65536").End(xlUp).Row - 1
Res = Range("b2").Value
q = 0
ReDim Comblist(0) As String
ReDim b(n)
ReDim listx(n)
ReDim Ans(0)
For k = 1 To n
Comb 1, 0
Next k
For i = 1 To n
listx(i) = Range("a" & 1 + i).Value
Next i
AnsCount = 0
For i = LBound(Comblist) To UBound(Comblist)
St = ""
tmp = 0
For j = 1 To Len(Comblist(i))
tmp = tmp + Mid(Comblist(i), j, 1) * listx(j)
If Mid(Comblist(i), j, 1) = 1 Then
St = St & "+" & listx(j)
End If
Next j
If tmp = Res Then 'Or (tmp >= 0.9 * Res And tmp<= 1.1 * Res) Then
ReDim Preserve Ans(UBound(Ans) + 1)
AnsCount = AnsCount + 1
Ans(AnsCount) = St
End If
Next i
Range("e2:Z65536").ClearContents
For i = LBound(Ans) + 1 To UBound(Ans)
Range("e" & i + 1).Value = "=" & Ans(i)
nums = Split(Ans(i), "+")
For k = 1 To UBound(nums)
Range("E" & i + 1).Offset(0, k) = nums(k)
Next k
Next i
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub
```