From the 8 numbers, generate permutations with set of 9 numbers, with target sum of 7

[motilulla]

Hello,

Please I need help with permutations.

Data-1 I got 8 numbers in the column "A" cell A6:A13 (0,1,2,3,4,5,6 and 7)
Data-2 my target permutation sum of each line, which is 7, is in the cell B3

I want using above data create all possible permutations with set of 9 numbers in the columns C:K and sum target of each line must be 7 as shown in the column M

For this example result, sample image is attached.

*	A	B	C	D	E	F	G	H	I	J	K	L	M	N	O
1
2	Find
3	Sum	7
4
5	Numbers		n1	n2	n3	n4	n5	n6	n7	n8	n9		Sum
6	0		1	0	1	1	1	1	0	1	1		7
7	1		0	1	1	1	1	1	1	1	0		7
8	2		0	0	0	0	2	2	0	1	2		7
9	3		0	0	0	1	1	2	0	2	1		7
10	4		0	0	0	1	2	1	1	2	0		7
11	5		0	0	0	1	3	0	1	0	2		7
12	6		0	0	0	2	1	3	0	1	0		7
13	7		0	0	0	2	3	1	1	0	0		7
14			0	0	0	3	1	0	1	0	2		7
15			0	0	1	0	1	1	1	1	2		7
16			1	0	3	1	1	0	1	0	0		7
17			1	0	4	0	0	0	1	0	1		7
18			1	0	4	0	0	1	1	0	0		7
19			1	1	0	0	1	0	2	1	1		7
20			1	1	1	3	0	1	0	0	0		7
21			1	1	1	3	1	0	0	0	0		7
22			1	1	1	3	1	0	0	0	0		7
23			1	1	2	0	0	1	0	2	0		7
24			1	1	3	0	1	0	1	0	0		7
25			1	1	3	1	0	0	1	0	0		7
26			1	2	0	3	1	0	0	0	0		7
27			1	2	0	4	0	0	0	0	0		7
28			1	2	0	4	0	0	0	0	0		7
29			1	4	1	1	0	0	0	0	0		7
30			2	0	0	0	0	0	0	3	2		7
31			2	2	2	0	0	0	0	0	1		7
32			2	2	2	0	1	0	0	0	0		7
33			2	3	0	0	0	0	0	1	1		7
34			3	0	1	1	1	0	1	0	0		7
35			3	0	1	1	1	1	0	0	0		7
36			5	1	0	1	0	0	0	0	0		7
37			5	1	0	1	0	0	0	0	0		7
38			5	1	1	0	0	0	0	0	0		7
39			5	1	1	0	0	0	0	0	0		7
40			5	1	1	0	0	0	0	0	0		7
41			6	0	0	0	0	0	0	1	0		7
42			6	0	0	0	0	0	1	0	0		7
43			6	0	0	1	0	0	0	0	0		7
44			6	0	0	1	0	0	0	0	0		7
45			6	1	0	0	0	0	0	0	0		7
46			7	0	0	0	0	0	0	0	0		7
47
48

Thank you all.

I am using Excel 2000

Regards,
Moti

 

[Marc L]

​

As my way is yet published on several forums but you missed my question :​

And is your attachment well reflecting your real workbook ?

 

[motilulla]

Hello,

Finally I got a code working as per my need with my version results in 0:00:01 seconds

Thank you all for assisting here for my query, I am living code here may some one require.

Sub SplitInTo9Cells_8Num_0To7_BySumA6()

    
      Range("C6:M6441").ClearContents
      Range("C6").Select
'-----------------------------Timer----------------------------------------------------------
Dim dtStartTime As Date
    dtStartTime = Now()
'-----------------------------Timer----------------------------------------------------------

Dim nextRow As Long
Dim n1 As Long, n2 As Long, n3 As Long, n4 As Long, n5 As Long, n6 As Long, n7 As Long, n8 As Long, n9 As Long

'-------------------------------------------------------------------------------------------
    'Use ScreenUpdating property to turn screen updating off to speed up your macro code:
    'Prevents screen refreshing.
    Application.ScreenUpdating = False
'-------------------------------------------------------------------------------------------

nextRow = 5

For n1 = 0 To 7
 For n2 = 0 To 7 - n1
  For n3 = 0 To 7 - n1 - n2
   For n4 = 0 To 7 - n1 - n2 - n3
    For n5 = 0 To 7 - n1 - n2 - n3 - n4
     For n6 = 0 To 7 - n1 - n2 - n3 - n4 - n5
      For n7 = 0 To 7 - n1 - n2 - n3 - n4 - n5 - n6
       For n8 = 0 To 7 - n1 - n2 - n3 - n4 - n5 - n6 - n7
        For n9 = 0 To 7 - n1 - n2 - n3 - n4 - n5 - n6 - n7 - n8
            
          
          RowSum = n1 + n2 + n3 + n4 + n5 + n6 + n7 + n8 + n9
          If RowSum = Range("B3").Value Then
          

             nextRow = nextRow + 1
            
             Cells(nextRow, 3).Value = n1
             Cells(nextRow, 4).Value = n2
             Cells(nextRow, 5).Value = n3
             Cells(nextRow, 6).Value = n4
             Cells(nextRow, 7).Value = n5
             Cells(nextRow, 8).Value = n6
             Cells(nextRow, 9).Value = n7
             Cells(nextRow, 10).Value = n8
             Cells(nextRow, 11).Value = n9

         End If
        
            
        Next
       Next
      Next
     Next
    Next
   Next
  Next
 Next
Next


'------------------------------------------------------------------------------------------------------------------------------
   'You won't be able to see what the macro is doing, but it will run faster. When your macro ends don't forget to set the
   'Enables screen refreshing.
   Application.ScreenUpdating = True
'------------------------------------------------------------------------------------------------------------------------------
 
  Dim lngLastRow As Long
  lngLastRow = Cells(Rows.Count, "C").End(xlUp).Row
 
  Range("M6:M" & lngLastRow).Formula = "=SUM(C7:K7)"
  Range("M7:M" & lngLastRow) = Range("M7:M" & lngLastRow).Value 'Convert Values
 
 
'-----------------------------Timer----------------------------------------------------------
MsgBox "Macro ran successfully in " & _
            FormatDateTime(Now() - dtStartTime, 3), vbInformation
'-----------------------------Timer----------------------------------------------------------


End Sub

Have a nice weekend

Kind Regards,
Moti

 

[Marc L]

​

What happens with this code if you change the numbers values in A6:A13 ? …​

​

'Your code' needs more than 3s on my tests old laptop computer, working with arrays should need less than 0.3s …​

​

 

[motilulla]

​

What happens with this code if you change the numbers values in A6:A13 ? …​

​

Marc L, totally agree with you I am not able to code this option so far I live it unsolved may some can help to make a code which can read the values are in cell A6:A13...that would be really great.

Thank you for your observations, have a good start of the week

Kind Regards,
Moti

 

[Marc L]

Without any answer to my posts #9 & #11 question - but according to your post #12 code I presume it's yes - this is a one shot demonstration​

(needs 0.2s on my side, ready since post #5 - in fact since last century ! - but meaning I won't modify its code whatever the reason …)​

to paste to the top of a module (the better place is the worksheet module) :​

Dim P%(), R&, S%(), V()

Sub PSum(T%, Optional ByVal C% = 1)
    Dim N&, Z%
    For N = 1 To UBound(V)
        Z = T - V(N):  If Z < 0 Then Exit Sub
        P(C) = V(N)
        If C < UBound(P) Then PSum Z, C + 1 Else If Z = 0 Then R = R + 1: For C = 1 To C: S(R, C) = P(C): Next: Exit Sub
    Next
End Sub

Sub Demo1()
        T! = Timer
    With [C5].CurrentRegion.Rows
        If .Columns.Count = 1 Then Beep: Exit Sub
        If .Count > 1 Then .Item("2:" & .Count).ClearContents
    With Range("A6", [A5].End(xlDown))
        V = Application.Small(.Value2, Evaluate("COLUMN(" & [A1].Resize(, .Rows.Count).Address & ")"))
    End With
        If [B3].Value2 > V(UBound(V)) * .Columns.Count Then Beep: Erase V: Exit Sub
        ReDim P(1 To .Columns.Count), S(1 To Rows.Count - 5, 1 To .Columns.Count)
        R = 0
        PSum [B3].Value2
        If R Then .Item(2).Resize(R).Value2 = S
    End With
        Debug.Print Format(Timer - T, "0.000s")
        Erase P, S, V
End Sub

 

[motilulla]

Without any answer to my posts #9 & #11 question - but according to your post #12 code I presume it's yes - this is a one shot demonstration​

(needs 0.2s on my side, ready since post #5 - in fact since last century ! - but meaning I won't modify its code whatever the reason …)​

to paste to the top of a module (the better place is the worksheet module) :​

Dim P%(), R&, S%(), V()

Sub PSum(T%, Optional ByVal C% = 1)
    Dim N&, Z%
    For N = 1 To UBound(V)
        Z = T - V(N):  If Z < 0 Then Exit Sub
        P(C) = V(N)
        If C < UBound(P) Then PSum Z, C + 1 Else If Z = 0 Then R = R + 1: For C = 1 To C: S(R, C) = P(C): Next: Exit Sub
    Next
End Sub

Sub Demo1()
        T! = Timer
    With [C5].CurrentRegion.Rows
        If .Columns.Count = 1 Then Beep: Exit Sub
        If .Count > 1 Then .Item("2:" & .Count).ClearContents
    With Range("A6", [A5].End(xlDown))
        V = Application.Small(.Value2, Evaluate("COLUMN(" & [A1].Resize(, .Rows.Count).Address & ")"))
    End With
        If [B3].Value2 > V(UBound(V)) * .Columns.Count Then Beep: Erase V: Exit Sub
        ReDim P(1 To .Columns.Count), S(1 To Rows.Count - 5, 1 To .Columns.Count)
        R = 0
        PSum [B3].Value2
        If R Then .Item(2).Resize(R).Value2 = S
    End With
        Debug.Print Format(Timer - T, "0.000s")
        Erase P, S, V
End Sub

Marc L, I am sorry for replying you late because I did not had access to my desktop computer, I actually tried your code just now and it's working pretty well, actually better than mine as you suggested. Got results in 0:00:00 seconds, also it is reading the values are in cell A6:A13...that is really great option added by you.

Thanks for you help once again. Have a good start of the week ahead

Kind Regards
Moti