vba - permutations

[montecarlo2012]

Hello.

Sub ListPermut()
'This macro creates a list of all permutations
 
'Define variables
Dim ws As Worksheet, Ans As String, ans1() As String, digits As Integer
Dim num As Integer, p As Long, i As Long, t As Long
Dim rng() As Long, c As Long, rng1() As String
 

 
'Ask for user input
Ans = InputBox("Type strings separated with a comma:")
digits = InputBox("How many strings?")
 
'Split text strings to an array
ans1 = Split(Ans, ",")
 
'Count values in aray
num = UBound(ans1) + 1
 
'Calculate number of permutations
p = num ^ digits
 
'Redimension arrays
ReDim rng(1 To digits)
ReDim rng1(1 To digits)
 
'Save 1 to all values in first row of array
For c = 1 To digits
rng(c) = 1
Next c
 
i = 0
 
'Don't show the result until finished
Application.ScreenUpdating = False
 
'Repeat until all permutations have been created
Do Until (i + t) = (p - 1)
'Use text strings instead of numbers
For c = LBound(rng1) To UBound(rng1)
rng1(c) = ans1(rng(c) - 1)
Next c
'Transfer values from array to worksheet
Sheet1.Range("A1").Resize(, digits).Offset(i) = rng1
 
'Build next row of permutations
For c = digits To 1 Step -1
If c = digits Then
rng(c) = rng(c) + 1
ElseIf rng(c) = 0 Then
rng(c) = rng(c - 1)
End If
If rng(c) = num + 1 Then
rng(c) = 1
rng(c - 1) = rng(c - 1) + 1
End If
Next c
 
'Count made permutations
i = i + 1
 
'Insert a new sheet if rows exceed 999 999
If i = 1000000 Then
'Set ws = Sheets.Add
t = t + 1000000
i = 0
End If
 
Loop
'Use text strings instead of numbers
For c = LBound(rng1) To UBound(rng1)
rng1(c) = ans1(rng(c) - 1)
Next c
'Transfer values from array to worksheet
Sheet1.Range("A1").Resize(, digits).Offset(i) = rng1
'Show output
Application.ScreenUpdating = True
 
End Sub

This code return (" all ") the permutation,
I want to control "wich" permutation
example.

and the total.
the result of adding, here I separate manually whatever add 5, (I would like to control that)
also, you can see there are 2, and 1,1,1 and 0's
what about if I need the 2, 2, 1 and 0's only
How is possible to add this filters
Thank you for reading this

 

[BSALV]

hello,
Montecarlo

Later, it's easy to add an extra condition if the number of combinations exceeds the number of rows in a sheet.

Sub MonteCarlo()
     Dim Arr() As Integer, Out()
     Ans = InputBox("Type strings separated with a comma:")
     digits = InputBox("How many strings?")
     ReDim Arr(digits - 1)
     ReDim Out(digits)  '1 more because of 1 filter
     sp = Split(Ans, ",")     'cut you options on the "," separator

     t = Timer
     Set dict = CreateObject("scripting.dictionary")     '1st dictionary for ALL solutions
     Set dict1 = CreateObject("scripting.dictionary")     '2nd dictionary only for "good" solutions

     Do     'infinite loop
          som = 0     'reset som
          For i = 0 To UBound(Arr)     'loop all values of Arr
               Out(i) = sp(Arr(i))     'translate that number into the options of Ans
               som = som + Out(i)     'make the sum
          Next
          Out(UBound(Out)) = IIf(som = 5, "OK", "-")     'add an "OK" or a "-" in the last element
          dict.Add dict.Count, Out     'add solution to all the solutions
          If som = 5 Then dict1.Add dict.Count, Out     'conditional add to good solutions

          Arr(0) = Arr(0) + 1     'finding next solution = increment with 1
          For i = 0 To UBound(Arr) - 1     'loop all elements in Arr
               If Arr(i) > UBound(sp) Then Arr(i) = 0: Arr(i + 1) = Arr(i + 1) + 1 Else Exit For     'if 1element out of borders, next element +1 and reset that element
          Next
     Loop While Arr(UBound(Arr)) <= UBound(sp)

     ptr = dict.Count     'actual number of ALL solutions
     If ptr = 1 Then dict.Add dict.Count, dict.items()(0)     'problem with a dictionary with only 1 record, workaround = add a 2nd
     ptr1 = dict1.Count
     If ptr1 = 1 Then dict1.Add dict1.Count, dict1.items()(0)


     With ActiveSheet     'actual sheet
          .Cells.ClearContents     'make empty

          a = Application.Index(dict.items, 0, 0)
          .Range("A1").Resize(ptr, UBound(a, 2)).Value = a
          a = Application.Index(dict1.items, 0, 0)
          .Range("AA1").Resize(ptr1, UBound(a, 2)).Value = a

     End With

     MsgBox "Ready in " & Format(Timer - t, "0.0\s")

End Sub

 

[montecarlo2012]

BSALV, Hello.
Thanks for the code very interesting.
I expect to display only the permutation with a certain sum
another condition is the amount of 2's and ones in this case
do you think it is possible with a msgbox or in a cell to indicate that?
Thank you.

 

[BSALV]

here an example you can adapt to your needs.
run the macro "main" and it creates all combinations, the combinations with sum=5 and the combinations with 1 two and 3 one's.
MonteCarlo

 

[montecarlo2012]

Thank you BSALV