# VBA code: Just a little modification2

#### Arnolf

##### Board Regular
Hello,

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
ABCDEFGHIJ
1listDesired sumSumpossible combination
215.975.977.93-1.96
31.965.971.964.01
43
54.01
67.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``````

### Excel Facts

How can you automate Excel?
Press Alt+F11 from Windows Excel to open the Visual Basic for Applications (VBA) editor.

deleted

deleted

#### Arnolf

##### Board Regular
Norie,
One more time, thank you for your kind assistance.

Norie said:
Arnolf

Do you want it to stop when it finds the first solution(s)?

Yes. In my example case, the code should stop when find the combination for 5.97.

Norie said:
This almost works but for some reason repeats the combinations.

I'll try to find out about the repetition and post back.
Code:
``````Option Explicit
.
.
.

End Sub``````

As you said when I run your solution, I had 3 repetitions of the combinations.

rgds,
Arnolf.

help

#### Arnolf

##### Board Regular
your help will be much appreciated

...

b u m p

one more try

#### jindon

##### MrExcel MVP
try
Code:
``````Sub test()
Dim tgtVal As Double, a
Dim dic As Object, w(), x, z
Dim temp As Double, i As Long, ii As Long

Set dic = CreateObject("scripting.dictionary")
tgtVal = Range("b2").Value
a = Range("a2", Range("a" & Rows.Count).End(xlUp)).Value
VSortMA a, 1, UBound(a, 1), 1
For i = 1 To UBound(a, 1) - 1
For ii = i + 1 To UBound(a, 1)
temp = Abs((a(i, 1) + a(ii, 1)) - tgtVal)
If Not dic.exists(temp) Then
ReDim w(2, 0): w(0, 0) = a(i, 1) + a(ii, 1)
w(1, 0) = a(i, 1): w(2, 0) = a(ii, 1)
Else
w = dic(temp)
ReDim Preserve w(2, UBound(w, 2) + 1)
w(0, UBound(w, 2)) = a(i, 1) + a(ii, 1)
w(1, UBound(w, 2)) = a(i, 1)
w(2, UBound(w, 2)) = a(ii, 1)
dic(temp) = w
End If
Next
Next
x = dic.keys: Erase a
z = Application.Min(x)
w = dic(z)
With Range("e2")
With .CurrentRegion
.Offset(1).Resize(.Rows.Count - 1).ClearContents
End With
.Resize(UBound(w, 2) + 1, UBound(w, 1) + 1) _
= Application.Transpose(w)
End With
Set dic = Nothing: Erase a
End Sub

Private Sub VSortMA(ary, LB, UB, ref)
Dim M As Variant, temp
Dim i As Long, ii As Long, iii As Long
i = UB
ii = LB
M = ary(Int((LB + UB) / 2), ref)
Do While ii <= i
Do While ary(ii, ref) < M
ii = ii + 1
Loop
Do While ary(i, ref) > M
i = i - 1
Loop
If ii <= i Then
For iii = LBound(ary, 2) To UBound(ary, 2)
temp = ary(ii, iii): ary(ii, iii) = ary(i, iii)
ary(i, iii) = temp
Next
ii = ii + 1: i = i - 1
End If
Loop
If LB < i Then VSortMA ary, LB, i, ref
If ii < UB Then VSortMA ary, ii, UB, ref
End Sub``````

Replies
3
Views
157
Replies
1
Views
107
Replies
5
Views
198
Replies
3
Views
184
Replies
18
Views
392

1,196,017
Messages
6,012,872
Members
441,737
Latest member
bijayche

### We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.

### Which adblocker are you using?

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

### Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

### Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back