VBA code: Just a little modification2

[Arnolf]

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
	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

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

 

[Arnolf]

thank you

jindon!!! Thank you.
Yes, your code gives me the correct results for number 6.
But, testing for other numbers I get the next:
Example: If I enter number 7, your code gives combinations for the next greater value 7.01. In this case, it should be 6.97.
Please, Help.
rgds,
Arnolf


If I enter in B2 number 7, 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	7			6.97	1	7.93	-1.96
3	1.96				6.97	1	1.96	4.01
4	3
5	4.01
6	7.93
7	-1.96
8
Sheet3

If I enter in B2 number 8, 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	8			7.93	7.93
3	1.96				7.93	1.96	7.93	-1.96
4	3
5	4.01
6	7.93
7	-1.96
8
Sheet3

 

[Arnolf]

jindon,

I also have another problem with the below example worksheet
Please, your help is much appreciated.
rgds,
Arnolf



If I enter in B2 number 15. I need this:

combin.xls
	A	B	C	D	E	F	G	H	I	J
1	list	Desired sum			Sum	possible combination
2	1	15			15	4	5	6
3	2				15	3	5	7
4	3				15	2	6	7
5	4				15	2	3	4	6
6	5				15	1	3	5	6
7	6				15	1	3	4	7
8	7				15	1	2	5	7
9					15	1	2	3	4	5
10
Sheet3

But, with your code I get the next:

combin.xls
	A	B	C	D	E	F	G	H	I	J
1	list	Desired sum			Sum	possible combination
2	1	15			13	6	7
3	2
4	3
5	4
6	5
7	6
8	7
Sheet3

 

[jindon]

I thought it would be "nearest".
following code alone should solve the first requirement.

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
For i = 1 To UBound(a, 1) - 1
    For ii = i + 1 To UBound(a, 1)
        If a(i, 1) + a(ii, 1) <= tgtVal Then
        temp = 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)
            dic.Add temp, w
        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
        End If
    Next
Next
x = dic.keys: Erase a
z = Application.Max(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

 

[Arnolf]

please

Thank you jindon.
I am amazed how talented you are writing code.
I realized that I am a real dumb. I promise to learn VBA.

But, still getting non expected results.

Could it be a way the code get me the combination for an exact value in B2, and if there isnt a combination for that exact value, get me the combination for the minimum nearest value in B2? (all with the same code?).
I'd highly appreciate you still can help me.
rgds,
Arnolf


These are the non expected results that I get with your last code

combin.xls
	A	B	C	D	E	F	G	H	I	J
1	list	Desired sum			Sum	possible combination
2	1	7			5.97	1.96	4.01
3	1.96				5.97	7.93	-1.96
4	3
5	4.01
6	7.93
7	-1.96
Sheet3

combin.xls
	A	B	C	D	E	F	G	H	I	J
1	list	Desired sum			Sum	possible combination
2	1	8			7.01	3	4.01
3	1.96
4	3
5	4.01
6	7.93
7	-1.96
Sheet3

 

[Arnolf]

It seems this is more complicated that I imagine.

The next code, modified for Norie works excellent (I do not know why he deleted his posts). Only has the "little" problem that repeats the combination in the case to get combinations for the minimum nearest value in B2.
But, doesnt have any problem getting combinations for exact values in B2.
Please, help.

Option Explicit

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 Sum3xxx()
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)

Do
    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 Val(tmp) = Val(Res) Then
            ReDim Preserve Ans(UBound(Ans) + 1)
            AnsCount = AnsCount + 1
            Ans(AnsCount) = St
        End If
    Next i
    Res = Res - 0.01
  
Loop Until AnsCount <> 0

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

 

[Arnolf]

please.....