Make combinations until a require sum is reached...

[motilulla]

Hello,

I am looking a VBA collect the 6 number from the 6 rows which sums reach 15 in this given example (but if it is possible to make VBA flexible so can be chosen any sum)

Example1 picks 5 numbers from (row 3,4,5,6 &7 from 5 rows) from cells B3:B7 which sums =13 then check row 8 from B8:J8 adding each number with row (with cells B3:B7 total) if sum target 15 match list them in L2:Q2 as B3:B7 Total is 13 there is no number 2 in row 8 so no sum match found =15

Check this example1 below

Book1
	A	B	C	D	E	F	G	H	I	J	K	L	M	N	O	P	Q
1
2		n1	n2	n3	n4	n5	n6	n7	n8	n9		R1	R2	R3	R4	R5	R6
3		0	4	9	2	1	5	6	23	22
4		4	1	17	6	9	3	5	0	2
5		0	2	3	1	5	42	10	16	11
6		7	3	4	8	0	2	1	49	13
7		2	0	14	3	20	1	16	10	5
8		12	0	1	35	5	3	14	17	6
Hoja7

Example2 picks 4 numbers from (row 3,4,5 & 6 from 4 rows) from cells B3:B6 an one next number from row7 = 2 now sums are =11 then check again with row 8 from B8:J8 adding each number with row (with cells B3:B6 +C7 total) if sum target 15 match as B3:B6 +C7Total is 11 there is no number 4 in row 8 so no sum match found =15

Book1
	A	B	C	D	E	F	G	H	I	J	K	L	M	N	O	P	Q
1
2		n1	n2	n3	n4	n5	n6	n7	n8	n9		R1	R2	R3	R4	R5	R6
3		0	4	9	2	1	5	6	23	22
4		4	1	17	6	9	3	5	0	2
5		0	2	3	1	5	42	10	16	11
6		7	3	4	8	0	2	1	49	13
7		2	0	14	3	20	1	16	10	5
8		12	0	1	35	5	3	14	17	6
Hoja7

Example3 repeat the step above pick next number in row 7 = 14 now 11+14 =25 no match 15 found

Book1
	A	B	C	D	E	F	G	H	I	J	K	L	M	N	O	P	Q
1
2		n1	n2	n3	n4	n5	n6	n7	n8	n9		R1	R2	R3	R4	R5	R6
3		0	4	9	2	1	5	6	23	22
4		4	1	17	6	9	3	5	0	2
5		0	2	3	1	5	42	10	16	11
6		7	3	4	8	0	2	1	49	13
7		2	0	14	3	20	1	16	10	5
8		12	0	1	35	5	3	14	17	6
Hoja7

Example4 repeat the step above pick next number in row 7 = 3 now 11+3 =14 and in row 8 found number 1 so 14+1 = 15 match found list it in L2:Q2

Book1
	A	B	C	D	E	F	G	H	I	J	K	L	M	N	O	P	Q
1
2		n1	n2	n3	n4	n5	n6	n7	n8	n9		R1	R2	R3	R4	R5	R6
3		0	4	9	2	1	5	6	23	22		0	4	0	7	3	1
4		4	1	17	6	9	3	5	0	2
5		0	2	3	1	5	42	10	16	11
6		7	3	4	8	0	2	1	49	13
7		2	0	14	3	20	1	16	10	5
8		12	0	1	35	5	3	14	17	6
Hoja7

Example5 repeat the step above pick next number in row 7 = 20 now 11+20 =31 no match 15 found

Book1
	A	B	C	D	E	F	G	H	I	J	K	L	M	N	O	P	Q
1
2		n1	n2	n3	n4	n5	n6	n7	n8	n9		R1	R2	R3	R4	R5	R6
3		0	4	9	2	1	5	6	23	22		0	4	0	7	3	1
4		4	1	17	6	9	3	5	0	2
5		0	2	3	1	5	42	10	16	11
6		7	3	4	8	0	2	1	49	13
7		2	0	14	3	20	1	16	10	5
8		12	0	1	35	5	3	14	17	6
Hoja7

Example6 repeat the step above pick next number in row 7 = 1 now 11+1 =12 and in row 8 found number 3 so 12+3 = 15 match found list it in L3:Q3

Book1
	A	B	C	D	E	F	G	H	I	J	K	L	M	N	O	P	Q
1
2		n1	n2	n3	n4	n5	n6	n7	n8	n9		R1	R2	R3	R4	R5	R6
3		0	4	9	2	1	5	6	23	22		0	4	0	7	3	1
4		4	1	17	6	9	3	5	0	2		0	4	0	7	1	3
5		0	2	3	1	5	42	10	16	11
6		7	3	4	8	0	2	1	49	13
7		2	0	14	3	20	1	16	10	5
8		12	0	1	35	5	3	14	17	6
Hoja7

Here are some more matches but not all

Book1
	A	B	C	D	E	F	G	H	I	J	K	L	M	N	O	P	Q
1
2		n1	n2	n3	n4	n5	n6	n7	n8	n9		R1	R2	R3	R4	R5	R6
3		0	4	9	2	1	5	6	23	22		0	4	0	7	3	1
4		4	1	17	6	9	3	5	0	2		0	4	0	7	1	3
5		0	2	3	1	5	42	10	16	11		0	4	0	3	3	5
6		7	3	4	8	0	2	1	49	13		0	4	0	3	5	3
7		2	0	14	3	20	1	16	10	5		0	4	0	4	2	5
8		12	0	1	35	5	3	14	17	6		0	4	0	4	1	6
9												0	4	0	8	2	1
10												0	4	0	8	0	3
11												0	4	0	0	5	6
12												0	4	0	2	3	6
13												0	4	0	1	5	5
14												0	4	2	7	1	1
15												0	4	2	3	3	3
16												0	4	2	4	2	3
17												0	4	2	0	3	6
18												0	4	2	2	2	5
Hoja7

Please need VBA solution to get all combinations

Thank you all

Excel 2000
Regards,
Moti

 

[B___P]

Hi Moti,
new code calculates max sum, this way there is no need to hardcode it.

Sub moti_11_2016_OnlyReport1Pass2()
Dim x1 As Long: Dim x2 As Long: Dim x3 As Long
Dim x4 As Long: Dim x5 As Long: Dim x6 As Long
Dim mynumbers As Variant
Dim check As Long
Dim x As Long
Dim maxsum As Long
Dim check1 As Variant

'calculates max sum
[COLOR=#ff0000]maxsum = WorksheetFunction.Max(Range("B3:J3")) + WorksheetFunction.Max(Range("B4:J4")) + WorksheetFunction.Max(Range("B5:J5")) + _
        WorksheetFunction.Max(Range("B6:J6")) + WorksheetFunction.Max(Range("B7:J7")) + WorksheetFunction.Max(Range("B8:J8"))
[/COLOR]'
ReDim check1(0 To maxsum, 1 To 2)
For x = 0 To UBound(check1, 1)
    check1(x, 1) = x
    check1(x, 2) = 0
Next x
mynumbers = Range("B3:J8").Value
For x1 = 1 To 9: For x2 = 1 To 9: For x3 = 1 To 9: For x4 = 1 To 9: For x5 = 1 To 9: For x6 = 1 To 9
    check = (mynumbers(1, x1) + mynumbers(2, x2) + mynumbers(3, x3) + mynumbers(4, x4) + mynumbers(5, x5) + mynumbers(6, x6)) ' = check Then
    check1(check, 2) = check1(check, 2) + 1
Next x6: Next x5: Next x4: Next x3: Next x2: Next x1
Range("[COLOR=#ff0000]Q[/COLOR]3:[COLOR=#ff0000]R[/COLOR]" & (maxsum + 3)) = check1 'edit columns to change output layout
MsgBox ("E N D")
End Sub

if you want to change columns output to Y:Z change this line

Range("[COLOR=#ff0000]Q[/COLOR]3:[COLOR=#ff0000]R[/COLOR]" & (maxsum + 3)) = check1

to

Range("[COLOR=#ff0000]Y[/COLOR]3:[COLOR=#ff0000]Z[/COLOR]" & (maxsum + 3)) = check1

Have a nice rest of the day

 

[motilulla]

Hi Moti,
new code calculates max sum, this way there is no need to hardcode it.

Sub moti_11_2016_OnlyReport1Pass2()
Dim x1 As Long: Dim x2 As Long: Dim x3 As Long
Dim x4 As Long: Dim x5 As Long: Dim x6 As Long
Dim mynumbers As Variant
Dim check As Long
Dim x As Long
Dim maxsum As Long
Dim check1 As Variant

'calculates max sum
[COLOR=#ff0000]maxsum = WorksheetFunction.Max(Range("B3:J3")) + WorksheetFunction.Max(Range("B4:J4")) + WorksheetFunction.Max(Range("B5:J5")) + _
        WorksheetFunction.Max(Range("B6:J6")) + WorksheetFunction.Max(Range("B7:J7")) + WorksheetFunction.Max(Range("B8:J8"))
[/COLOR]'
ReDim check1(0 To maxsum, 1 To 2)
For x = 0 To UBound(check1, 1)
    check1(x, 1) = x
    check1(x, 2) = 0
Next x
mynumbers = Range("B3:J8").Value
For x1 = 1 To 9: For x2 = 1 To 9: For x3 = 1 To 9: For x4 = 1 To 9: For x5 = 1 To 9: For x6 = 1 To 9
    check = (mynumbers(1, x1) + mynumbers(2, x2) + mynumbers(3, x3) + mynumbers(4, x4) + mynumbers(5, x5) + mynumbers(6, x6)) ' = check Then
    check1(check, 2) = check1(check, 2) + 1
Next x6: Next x5: Next x4: Next x3: Next x2: Next x1
Range("[COLOR=#ff0000]Q[/COLOR]3:[COLOR=#ff0000]R[/COLOR]" & (maxsum + 3)) = check1 'edit columns to change output layout
MsgBox ("E N D")
End Sub

if you want to change columns output to Y:Z change this line

Range("[COLOR=#ff0000]Q[/COLOR]3:[COLOR=#ff0000]R[/COLOR]" & (maxsum + 3)) = check1

to

Range("[COLOR=#ff0000]Y[/COLOR]3:[COLOR=#ff0000]Z[/COLOR]" & (maxsum + 3)) = check1

Have a nice rest of the day

Hello B___P, clever code now it is working with any max sum no problem thumbs up!! Also I appreciate for making ease the shift of result columns.

Many thanks to you for a great gob and for the kind help you gave me

Have a nice weekend

Kind Regards,
Moti