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

M

motilulla

Well-known Member
Joined
Feb 13, 2008
Messages
2,422
Office Version
  1. 2010
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.

*ABCDEFGHIJKLMNO
1
2Find
3Sum7
4
5Numbersn1n2n3n4n5n6n7n8n9Sum
601011110117
710111111107
820000220127
930001120217
1040001211207
1150001301027
1260002130107
1370002311007
140003101027
150010111127
161031101007
171040001017
181040011007
191100102117
201113010007
211113100007
221113100007
231120010207
241130101007
251131001007
261203100007
271204000007
281204000007
291411000007
302000000327
312220000017
322220100007
332300000117
343011101007
353011110007
365101000007
375101000007
385110000007
395110000007
405110000007
416000000107
426000001007
436001000007
446001000007
456100000007
467000000007
47
48

Thank you all.

I am using Excel 2000

Regards,
Moti
 

Attachments

  • 8 Number 9 Permutation.png
    8 Number 9 Permutation.png
    37.6 KB · Views: 24

Excel Facts

Why are there 1,048,576 rows in Excel?
The Excel team increased the size of the grid in 2007. There are 2^20 rows and 2^14 columns for a total of 17 billion cells.
Sort by date Sort by votes
Hello,

I got some code in my archive modified it for my requirement it seems to work and generate 6435 I guess it is correct numbers with sum of 7.

But it takes too much time. Please can anybody make it faster or the new one?

VBA Code: 
Sub Permutation()
Row = 6
inarr = Range(Cells(6, 3), Cells(6, 11))
For i1 = 0 To 7
 For i2 = 0 To 7
  For i3 = 0 To 7
    For i4 = 0 To 7
     For i5 = 0 To 7
      For i6 = 0 To 7
       For i7 = 0 To 7
        For i8 = 0 To 7
         For i9 = 0 To 7
          RowSum = i1 + i2 + i3 + i4 + i5 + i6 + i7 + i8 + i9
          'If RowSum = 7 Then
           If RowSum = Range("B3").Value Then
          inarr(1, 1) = i1
          inarr(1, 2) = i2
          inarr(1, 3) = i3
          inarr(1, 4) = i4
          inarr(1, 5) = i5
          inarr(1, 6) = i6
          inarr(1, 7) = i7
          inarr(1, 8) = i8
          inarr(1, 9) = i9
          Range(Cells(Row, 3), Cells(Row, 11)) = inarr
          Row = Row + 1
         End If
          Next i9
         Next i8
        Next i7
       Next i6
      Next i5
     Next i4
    Next i3
   Next i2
  Next i1
End Sub

Thank you all.

Regards,
Moti
 
Upvote 0
Hi,​
​
as lack of logic « takes to much time » ! So abort a loop at least when the sum is over the expected one …​
​
And store all your matching results in a single array rather than writing row-by-row …​
 
Upvote 0
This takes about a minute to run on my PC. Not sure if that's a time-saver or not.

VBA Code: 
Sub Main()
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
Dim Nums() As Variant:      Nums = Range("A5:A" & Range("A" & Rows.Count).End(xlUp).Row).Value2
Dim lCnt As Integer:        lCnt = UBound(Nums)
Dim Tmp() As Variant:       ReDim Tmp(1 To lCnt)
Dim AL As Object:           Set AL = CreateObject("System.Collections.ArrayList")
Dim MX As Integer:          MX = [B2].Value

Perm Nums, Tmp, MX, 1, AL

With Range("C5").Resize(AL.Count)
    .Value = Application.Transpose(AL.toArray)
    .TextToColumns DataType:=xlDelimited, Semicolon:=True
    With .Offset(, 10)
        .Formula2R1C1 = "=SUM(RC[-10]:RC[-2])"
        .Value = .Value
    End With
End With
Application.ScreenUpdating = True
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
End Sub

Sub Perm(Org() As Variant, Tmp() As Variant, MX As Integer, lInd As Long, AL As Object)

With Application.WorksheetFunction
    For i = 0 To MX
        Tmp(lInd) = i
        If lInd = UBound(Org) Then
            If .Sum(Tmp) = MX Then
                AL.Add TJ(Tmp)
            End If
        Else
            Perm Org, Tmp, MX, lInd + 1, AL
        End If
    Next i
End With
End Sub

Function TJ(Tmp() As Variant) As String
For i = LBound(Tmp) To UBound(Tmp)
    TJ = TJ & Tmp(i)
    If i < UBound(Tmp) Then TJ = TJ & ";"
Next i
End Function
 
Upvote 0
Marc L said:
Hi,​
​
as lack of logic « takes to much time » ! So abort a loop at least when the sum is over the expected one …​
​
And store all your matching results in a single array rather than writing row-by-row …​
Click to expand...
Marc L, thank you for the reply, I do not have coding knowledge please could you help

Kind Regards,
Moti
 
Upvote 0
lrobbo314 said:
This takes about a minute to run on my PC. Not sure if that's a time-saver or not.

VBA Code: 
Sub Main()
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
Dim Nums() As Variant:      Nums = Range("A5:A" & Range("A" & Rows.Count).End(xlUp).Row).Value2
Dim lCnt As Integer:        lCnt = UBound(Nums)
Dim Tmp() As Variant:       ReDim Tmp(1 To lCnt)
Dim AL As Object:           Set AL = CreateObject("System.Collections.ArrayList")
Dim MX As Integer:          MX = [B2].Value

Perm Nums, Tmp, MX, 1, AL

With Range("C5").Resize(AL.Count)
    .Value = Application.Transpose(AL.toArray)
    .TextToColumns DataType:=xlDelimited, Semicolon:=True
    With .Offset(, 10)
        .Formula2R1C1 = "=SUM(RC[-10]:RC[-2])"
        .Value = .Value
    End With
End With
Application.ScreenUpdating = True
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
End Sub

Sub Perm(Org() As Variant, Tmp() As Variant, MX As Integer, lInd As Long, AL As Object)

With Application.WorksheetFunction
    For i = 0 To MX
        Tmp(lInd) = i
        If lInd = UBound(Org) Then
            If .Sum(Tmp) = MX Then
                AL.Add TJ(Tmp)
            End If
        Else
            Perm Org, Tmp, MX, lInd + 1, AL
        End If
    Next i
End With
End Sub

Function TJ(Tmp() As Variant) As String
For i = LBound(Tmp) To UBound(Tmp)
    TJ = TJ & Tmp(i)
    If i < UBound(Tmp) Then TJ = TJ & ";"
Next i
End Function
Click to expand...
lrobbo314, thank you for the making fresh VBA, after I run the code getting the error, and highlight the line below

Run-time error -2146232576 (80121700)
Automation error
Dim AL As Object: Set AL = CreateObject("System.Collections.ArrayList")

Please could you take a look?

Kind Regards,
Moti
 
Upvote 0
Means that you don't have .Net installed on your computer. Swapping out the arraylist for a dictionary should do the trick.

VBA Code: 
Sub Main()
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
Dim Nums() As Variant:      Nums = Range("A5:A" & Range("A" & Rows.Count).End(xlUp).Row).Value2
Dim lCnt As Integer:        lCnt = UBound(Nums)
Dim Tmp() As Variant:       ReDim Tmp(1 To lCnt)
Dim AL As Object:           Set AL = CreateObject("Scripting.Dictionary")
Dim MX As Integer:          MX = [B2].Value

Perm Nums, Tmp, MX, 1, AL

With Range("C5").Resize(AL.Count)
    .Value = Application.Transpose(AL.keys())
    .TextToColumns DataType:=xlDelimited, Semicolon:=True
    With .Offset(, 10)
        .Formula2R1C1 = "=SUM(RC[-10]:RC[-2])"
        .Value = .Value
    End With
End With
Application.ScreenUpdating = True
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
End Sub

Sub Perm(Org() As Variant, Tmp() As Variant, MX As Integer, lInd As Long, AL As Object)

With Application.WorksheetFunction
    For i = 0 To MX
        Tmp(lInd) = i
        If lInd = UBound(Org) Then
            If .Sum(Tmp) = MX Then
                AL.Add Join(Tmp, ";"), 1
            End If
        Else
            Perm Org, Tmp, MX, lInd + 1, AL
        End If
    Next i
End With
End Sub
 
Upvote 0
lrobbo314 said:
Means that you don't have .Net installed on your computer. Swapping out the arraylist for a dictionary should do the trick.

VBA Code: 
Sub Main()
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
Dim Nums() As Variant:      Nums = Range("A5:A" & Range("A" & Rows.Count).End(xlUp).Row).Value2
Dim lCnt As Integer:        lCnt = UBound(Nums)
Dim Tmp() As Variant:       ReDim Tmp(1 To lCnt)
Dim AL As Object:           Set AL = CreateObject("Scripting.Dictionary")
Dim MX As Integer:          MX = [B2].Value

Perm Nums, Tmp, MX, 1, AL

With Range("C5").Resize(AL.Count)
    .Value = Application.Transpose(AL.keys())
    .TextToColumns DataType:=xlDelimited, Semicolon:=True
    With .Offset(, 10)
        .Formula2R1C1 = "=SUM(RC[-10]:RC[-2])"
        .Value = .Value
    End With
End With
Application.ScreenUpdating = True
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
End Sub

Sub Perm(Org() As Variant, Tmp() As Variant, MX As Integer, lInd As Long, AL As Object)

With Application.WorksheetFunction
    For i = 0 To MX
        Tmp(lInd) = i
        If lInd = UBound(Org) Then
            If .Sum(Tmp) = MX Then
                AL.Add Join(Tmp, ";"), 1
            End If
        Else
            Perm Org, Tmp, MX, lInd + 1, AL
        End If
    Next i
End With
End Sub
Click to expand...
lrobbo314, code worked but it took 3 times more longer time then code I posted in the #Post1. Secondly it split in 8 columns not in the 9, as I want

I am not sure what I am doing wrong, note I tried in one new fresh workbook also.

I want to remind that I am using old version, which is excel 2000.

Kind Regards,
Moti
 
Upvote 0
​
Normally on some basic slow computer according to Excel / VBA basics it should need around a second​
to compute the 6435 combinations and to allocate them to the columns C:K under Excel 2010 …​
I have no idea under Excel 2000 but it should be closed - let's say less than five seconds - but what is your time ?​
​
And is your attachment well reflecting your real workbook ?​
 
Upvote 0
Marc L said:
​
Normally on some basic slow computer according to Excel / VBA basics it should need around a second​
to compute the 6435 combinations and to allocate them to the columns C:K under Excel 2010 …​
I have no idea under Excel 2000 but it should be closed - let's say less than five seconds - but what is your time ?​
​
And is your attachment well reflecting your real workbook ?​
Click to expand...
Marc L, reading your reply question with you macro takes around a second, I restart my computer create a new work book and put in to it first code from #Post1 and second code from #Post7 and install the timer in the both codes. As I restart the computer find significant change in time...

VBA Code: 
Dim dtStartTime As Date
    dtStartTime = Now()
    
    code here......
    
MsgBox "Macro ran successfully in " & _
            FormatDateTime(Now() - dtStartTime, 3), vbInformation

Code from #Post1 took 0:00:17 second generated total 6435 combinations with a set of 9

Code from #Post7 took 0:00:29 second generated total 3432 combinations with a set of 8

But still I need help code could be faster and generate a 6435 combinations with a set of 9

Kind Regards,
Moti
 
Upvote 0
You must log in or register to reply here.

Similar threads

N
  • Solved
Averaging every Nth cell in a column
Replies
9
Views
112
Peter_SSs
Peter_SSs
R
  • Question Question
Move row to bottom of range is cell value is zero
Replies
6
Views
323
Peter_SSs
Peter_SSs
D
  • Question Question
Compile error: Wrong number of arguments or invalid property assignment
Replies
2
Views
74
daveyc18
D
F
  • Solved
Location Selection to buy
Replies
7
Views
131
freddocp
F
J
  • Question Question
Calculation based on value in table based on date range
Replies
0
Views
286
jsand
J

Forum statistics

Threads
1,224,823
Messages
6,181,181
Members
453,022
Latest member
Mohamed Magdi Tawfiq Emam

Share this page

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.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

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

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

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