?
Solved

Permutation with "n" numbers

Posted on 2000-01-19
30
Medium Priority
?
176 Views
Last Modified: 2010-05-02
I have three "slots". I have "n" numbers (at least three). I have to place these numbers into the slots in all available variation, without leaving empty slots. Like if I get the numbers 1, 2 and 3, the variations are: 1 2 3; 1 3 2; 2 1 3
2 3 1; 3 1 2; 3 2 1.
The question is what is the code for that? With 4 numbers or 5 or ANY.
Naturally, a "slot" can hold any numbers, but at least one!
0
Comment
Question by:Psycho1
  • 12
  • 9
  • 3
  • +4
30 Comments
 

Author Comment

by:Psycho1
ID: 2367154
If i get the numbers 1, 2 and 2 there's 6 solutions too. The user can enter anything. I have to separate'em.
0
 
LVL 15

Expert Comment

by:ameba
ID: 2367204
>If i get the numbers 1, 2 and 2 there's 6 solutions too
What 6 solutions?
0
 
LVL 18

Expert Comment

by:deighton
ID: 2367255
use this allanags routine, sends them to the debug window at the moment

Option Explicit


Private Function bubble(x() As String, i As Long)

    Dim c As Long
    Dim bF As Boolean
    Dim z As String
   
    Dim y() As String
   
    ReDim y(i)
   
    Do
       
        bF = True
        For c = 1 To i - 1
       
            If x(c) > x(c + 1) Then
                bF = False
                z = x(c)
                x(c) = x(c + 1)
                x(c + 1) = z
            End If
        Next
    Loop Until bF
   

End Function

Private Function factorial(i As Integer) As Long

    Dim c As Integer
   
    factorial = 1
    For c = 2 To i
        factorial = factorial * c
    Next

End Function

Private Function perm(x() As String, sString, number)

    Dim iLen As Integer
    Dim sTarget As String
    Dim lCount As Long
    Dim c As Integer
    Dim d As Long
    Dim l, r
   
    iLen = Len(sString)

    If iLen = 1 Then
   
       
        x(1) = sString
        number = 1
       
    Else
   
        Dim a() As String
        ReDim a(factorial(iLen))
               
        For c = 1 To iLen
               
            If c > 1 Then
                l = Mid(sString, 1, c - 1)
            Else
                l = ""
            End If
            If c < iLen Then
                r = Mid(sString, c + 1, iLen - c)
            Else
                r = ""
            End If
           
            sTarget = l & r
            lCount = 0
            Call perm(a, sTarget, lCount)
            For d = 1 To lCount
                number = number + 1
                x(number) = Mid(sString, c, 1) & a(d)
            Next
           
        Next
       
    End If
           

End Function




Private Sub allanags(sstr As String)

    Dim x() As String
    Dim number As Long
    Dim c As Long
   
    ReDim x(factorial(Len(sstr)))
   
   
    Call perm(x(), sstr, number)
   
    Call bubble(x, number)
   
    For c = 1 To number
   
        Debug.Print x(c)
       
    Next
    Stop
   
   

End Sub

Private Sub Command1_Click()

    Call allanags("1234")

End Sub
0
Never miss a deadline with monday.com

The revolutionary project management tool is here!   Plan visually with a single glance and make sure your projects get done.

 
LVL 6

Expert Comment

by:anthonyc
ID: 2367409
Here is the theory on how to do it

1)  Calculate how many permutations there are.  Basically the calculation is:

Size = N! / (A! * (N-A)!)

Where N is the total number, and A is the container size (! is factorial)


2)  Build a 2 dimensional array:

redim x(1 to N, 1 to A) as integer

3)  Populate the array with this code

k = 0 'offset
for i = 1 to Size
   for j = 1 to A
      x(i,j) = (((i - 1) mod n) + 1)
      if j = 1 then  
         x(i,j) = x(i,j) + k
         k = k + 1
         if k >= n then k = 0
      end if
   next j
next i

Now the array will contain all of the combinations, "vertically".  

For example, perm #1 is

x(1, 1) & x(1, 2) & ... & x(1,n)



Make sense?
0
 
LVL 2

Expert Comment

by:johnny6
ID: 2369159
Interesting question...I think anthonyc has a good, simple algorithm.
0
 
LVL 22

Expert Comment

by:ture
ID: 2369860
Psycho1,

Here's my suggestion:

Sub SlotMachine()
  Dim n As Long, s1 As Long, s2 As Long, s3 As Long, c As Long
  n = 3
  Debug.Print "List of possible combinations"
  For s1 = 1 To n
    For s2 = 1 To n
      For s3 = 1 To n
        If s1 <> s2 And s1 <> s3 And s2 <> s3 Then
          c = c + 1
          Debug.Print s1, s2, s3
        End If
      Next s3
    Next s2
  Next s1
  Debug.Print "Number of combinations: "; c
End Sub

Ture Magnusson
Karlstad, Sweden
0
 

Author Comment

by:Psycho1
ID: 2370024
Thanks but (how I wrote) I have to place them into that three slots (a simple List). So if the user gave me four numbers the solutions can be (for example):

1  2  3
4

or

1  3  4
2

and so on.

The "permutation-section" not solves this exactly.
0
 

Author Comment

by:Psycho1
ID: 2370026
deighton:

I'm increased the points to 200.
0
 
LVL 22

Expert Comment

by:ture
ID: 2370057
Psycho1,

Do you mean that you want to save all combinations in an array? Here is a procedure that does that. and shows the array afterwards.

Sub TuresSlotMachine()
  Dim slots() As Long
  Dim n As Long, s1 As Long, s2 As Long, s3 As Long, c As Long, r As Long
  n = 3
       
  'Save all possible combinations to an array
  For s1 = 1 To n
    For s2 = 1 To n
      For s3 = 1 To n
        If s1 <> s2 And s1 <> s3 And s2 <> s3 Then
          c = c + 1
          ReDim Preserve slots(1 To 3, 1 To c)
          slots(1, c) = s1
          slots(2, c) = s2
          slots(3, c) = s3
        End If
      Next s3
    Next s2
  Next s1
 
  'Now, let's see the list
  Debug.Print "List of possible combinations:"
  For r = 1 To c
    Debug.Print slots(1, r), slots(2, r), slots(3, r)
  Next r
  Debug.Print "Number of combinations: "; c
End Sub

/Ture
0
 

Author Comment

by:Psycho1
ID: 2370071
deighton:

Another thing! The user can enter ANY numbers. Like 34, 125, 1987065, 1, 9 etc.
0
 
LVL 22

Expert Comment

by:ture
ID: 2370078
Psycho1,

It seems as if you are communicating only with deighton. Are the rest of us completely off target?

/Ture
0
 
LVL 22

Expert Comment

by:ture
ID: 2370092
My procedure again, modified to enter all possible combinations of a list of numbers into the three slots.

Sub TuresSlotMachine()
  Dim numbers, slots() As Long
  Dim s1 As Long, s2 As Long, s3 As Long, c As Long, r As Long
   
  numbers = Array(5, 11, 793, 1024)
       
  'Save all possible combinations to an array
  For s1 = 0 To UBound(numbers)
    For s2 = 0 To UBound(numbers)
      For s3 = 0 To UBound(numbers)
        If s1 <> s2 And s1 <> s3 And s2 <> s3 Then
          c = c + 1
          ReDim Preserve slots(1 To 3, 1 To c)
          slots(1, c) = numbers(s1)
          slots(2, c) = numbers(s2)
          slots(3, c) = numbers(s3)
        End If
      Next s3
    Next s2
  Next s1
 
  'Now, let's see the list
  Debug.Print "List of possible combinations:"
  For r = 1 To c
    Debug.Print slots(1, r), slots(2, r), slots(3, r)
  Next r
  Debug.Print "Number of combinations: "; c
End Sub

/Ture
0
 

Author Comment

by:Psycho1
ID: 2370143
ture:

It works, but (I wrote it before) I need all the combinations. Any slot can hold any numbers(at least one). So with your example (5, 11, 793, 1024) one of the solutions is:

slot1  slot2  slot3
 5      11     793
1024

If you give me another code wich one is doing this thing I'll unlock the question for you and the points are yours.
0
 
LVL 22

Expert Comment

by:ture
ID: 2370214
Psycho1,

Thanks for responding.

I think that I misunderstood you before. Is this interpretation correct?

1. Each slot can hold one OR SEVERAL numbers.

2. In each combination, ALL the numbers should be put into slots.

What result do you want? A three-dimensional array with all combinations? Or perhaps it's enough with just a count of the number of combinations?

/Ture
0
 
LVL 18

Expert Comment

by:deighton
ID: 2370365
'Here it is

    Dim N As Integer 'number of numbers
    Dim iSlot() As Integer
    Dim x As Integer
    Dim y As Integer
    Dim z As Integer
    Dim O() As Integer
    Dim c As Long
    Dim bSorted As Boolean, b As Boolean
    Dim d As Long
    Dim temp1, temp2, temp3
   
   
    N = 4
    ReDim iSlot(1 To 3, factorial(N))
    ReDim O(1 To N)
   
   
    O(1) = 1
    O(2) = 4
    O(3) = 4
    O(4) = 4
   
    For x = 1 To N
    For y = 1 To N
    For z = 1 To N
       
        If x <> y And y <> z And x <> z Then
           
            c = c + 1
            iSlot(1, c) = O(x)
            iSlot(2, c) = O(y)
            iSlot(3, c) = O(z)
           
        End If
       
    Next z, y, x
   
           
    Do
        bSorted = True
        For d = 1 To c - 1
            b = False
            If iSlot(1, d) > iSlot(1, d + 1) Then
                b = True
            ElseIf iSlot(1, d) = iSlot(1, d + 1) Then
                If iSlot(2, d) > iSlot(2, d + 1) Then
                    b = True
                ElseIf iSlot(2, d) = iSlot(2, d + 1) Then
                    If iSlot(3, d) > iSlot(3, d + 1) Then
                        b = True
                    End If
                End If
            End If
            If b Then
                temp1 = iSlot(1, d)
                temp2 = iSlot(2, d)
                temp3 = iSlot(3, d)
                iSlot(1, d) = iSlot(1, d + 1)
                iSlot(2, d) = iSlot(2, d + 1)
                iSlot(3, d) = iSlot(3, d + 1)
                iSlot(1, d + 1) = temp1
                iSlot(2, d + 1) = temp2
                iSlot(3, d + 1) = temp3
                bSorted = False
            End If
        Next
    Loop Until bSorted
           
    temp1 = iSlot(1, 1)
    temp2 = iSlot(2, 1)
    temp3 = iSlot(3, 1)
   
    'islot holds all different permutations
    'print a list without repeated permutations
    'seems wise
   
    Debug.Print "**"
    Debug.Print temp1, temp2, temp3
    For d = 2 To c
        If temp1 <> iSlot(1, d) Or _
           temp2 <> iSlot(2, d) Or _
           temp3 <> iSlot(3, d) Then
            Debug.Print iSlot(1, d), iSlot(2, d), iSlot(3, d)
            temp1 = iSlot(1, d)
            temp2 = iSlot(2, d)
            temp3 = iSlot(3, d)
           
        End If
    Next

0
 
LVL 15

Expert Comment

by:ameba
ID: 2370383
0
 

Author Comment

by:Psycho1
ID: 2370438
ture:

I want a 3 dimensional array with all the combinations.

for example:

1  2  3          |BUT! This one's are 4                |the same!:
                 |
1  2  3          |1  2  3
   4             |4
                 |
etc.             |4  2  3
                 |1

I have to sort out the right side's solutions because they are the same.
And I need all the possible combinations with using every time all the numbers, and all the slots (can't be an empty slot).

deighton:
It looks like ture can give me a much smaller code.

I've increased the points to 250!
0
 

Author Comment

by:Psycho1
ID: 2370447
The example again, 'cause it looks dizzy... Sorry. :-(

1 2 3
4

1 2 3
  4
etc.

INCORRECT:

1 2 3
4

4 2 3
1

The first slot contains the same solution.
0
 
LVL 6

Expert Comment

by:anthonyc
ID: 2370589
guys..  Don't use 3 dimensional arrays.  Use collections or something instead.  There is never a need for a 3 dimensional array.  Not for something this trivial.

Did you read my theory, or just skip it because it didn't contain code?
0
 
LVL 15

Expert Comment

by:ameba
ID: 2370611
>guys..  Don't use 3 dimensional arrays.  
I am not using it. :)
0
 
LVL 22

Expert Comment

by:ture
ID: 2370671
Psycho1,

Here's another one for you!

Sub TuresSlotMachine()
  'Declare variables
  Dim Numbers As Variant
  Dim CountOfNumbers As Integer
  Dim Slots() As Long
  Dim CountOfNumbersInSlot(1 To 3) As Integer
  Dim SlotForThisNumber() As Integer
 
  Dim Counter As Long
  Dim WhichNumber As Integer
  Dim SlotNumber As Integer
  Dim SlotRowNumber As Integer
 
  Dim x As Long
  Dim r As Long
     
  'Initialize variables
  Numbers = Array(5, 11, 793, 1024)
  CountOfNumbers = UBound(Numbers) + 1
  ReDim SlotForThisNumber(1 To CountOfNumbers)
  ReDim Slots(1 To 3, 1 To CountOfNumbers, 1 To 1)
 
  'Initialize SlotForThisNumber to 1 for all numbers
  For WhichNumber = 1 To CountOfNumbers
    SlotForThisNumber(WhichNumber) = 1
  Next WhichNumber
 
  Do
    'Increase number of combinations and expand the Slots array
    Counter = Counter + 1
    ReDim Preserve Slots(1 To 3, 1 To CountOfNumbers, 1 To Counter)
   
    'Clear the number of entries in each Slot
    For SlotNumber = 1 To 3
      CountOfNumbersInSlot(SlotNumber) = 0
    Next SlotNumber

    'Loop through all numbers from 1 to CountOfNumbers
    For WhichNumber = 1 To CountOfNumbers
      SlotNumber = SlotForThisNumber(WhichNumber)
      CountOfNumbersInSlot(SlotNumber) = CountOfNumbersInSlot(SlotNumber) + 1
      SlotRowNumber = CountOfNumbersInSlot(SlotNumber)
      Slots(SlotNumber, SlotRowNumber, Counter) = Numbers(WhichNumber - 1)
    Next WhichNumber
   
    'Clear the Slots array for the last combination
    'and decrease Counter with 1 if any slots are empty
    For SlotNumber = 1 To 3
      If CountOfNumbersInSlot(SlotNumber) = 0 Then
        For SlotRowNumber = 1 To CountOfNumbers
          Slots(1, SlotRowNumber, Counter) = 0
          Slots(2, SlotRowNumber, Counter) = 0
          Slots(3, SlotRowNumber, Counter) = 0
        Next SlotRowNumber
        Counter = Counter - 1
        Exit For
      End If
    Next SlotNumber

    'Exit loop if all entries in SlotForThisNumber are 3
    For WhichNumber = 1 To CountOfNumbers
      If SlotForThisNumber(WhichNumber) <> 3 Then Exit For
      Exit Do
    Next WhichNumber
   
    'Increase SlotForThisNumber counters
    SlotForThisNumber(CountOfNumbers) = SlotForThisNumber(CountOfNumbers) + 1
    For WhichNumber = CountOfNumbers To 2 Step -1
      If SlotForThisNumber(WhichNumber) = 4 Then
        SlotForThisNumber(WhichNumber) = 1
        SlotForThisNumber(WhichNumber - 1) = SlotForThisNumber(WhichNumber - 1) + 1
      End If
    Next WhichNumber
  Loop
 
  'Now, let's see the list
  Debug.Print "List of possible combinations:"
  For x = 1 To Counter
    Debug.Print "Combination #"; x
    For SlotRowNumber = 1 To CountOfNumbers
      If (Slots(1, SlotRowNumber, x) + Slots(2, SlotRowNumber, x) + Slots(3, SlotRowNumber, x)) <> 0 Then
        For SlotNumber = 1 To 3
          Debug.Print Slots(SlotNumber, SlotRowNumber, x),
        Next SlotNumber
        Debug.Print
      End If
    Next SlotRowNumber
  Next x
End Sub

/Ture
0
 

Author Comment

by:Psycho1
ID: 2370917
Ture:

It gaves me 24 solutions. I think it have to be 36? Am I right?
'Cause with 4 numbers # of solutions are:

(3 'on' 4 - 3 slots and 4 numbers)

(3*3*3*3 - (3*(2*2*2*2))) + 3

And it gives you 36. I fake it somewhere or your code is not perfect(yet :-)?
0
 
LVL 22

Expert Comment

by:ture
ID: 2371003
My code is not perfect yet. It still reports both of these as different combinations:

1 2 3
4

4 2 3
1

/Ture
0
 

Author Comment

by:Psycho1
ID: 2371054
Ture:

I hope that you want to make it perfect, because I want to give you that points! :-))
Anyway! With four numbers there's must be 36 solutions! I'm sure.
0
 

Author Comment

by:Psycho1
ID: 2371077
Another comment for Ture:

Do not forget that the three slots are different! So this is a good group:

slot #1 #2 #3
     1  2  3
     4

     2  3  4
           1

That's why 36 solutions exists with 4 numbers.
0
 
LVL 22

Accepted Solution

by:
ture earned 1000 total points
ID: 2372801
Psycho1,

This code correctly produces 36 combinations for the four numbers given.
The problem with the previous code was that it ended before looping through all possible combinations.

Sub TuresSlotMachine()
  'Declare variables
  Dim Numbers As Variant
  Dim CountOfNumbers As Integer
  Dim Slots() As Long
  Dim CountOfNumbersInSlot(1 To 3) As Integer
  Dim SlotForThisNumber() As Integer
  Dim Counter As Long
  Dim WhichNumber As Integer
  Dim SlotNumber As Integer
  Dim SlotRowNumber As Integer
  Dim x As Long
     
  'Initialize variables
  Numbers = Array(5, 11, 793, 1024)
  CountOfNumbers = UBound(Numbers) + 1
  ReDim SlotForThisNumber(1 To CountOfNumbers)
  ReDim Slots(1 To 3, 1 To CountOfNumbers, 1 To 1)
 
  For WhichNumber = 1 To CountOfNumbers
    SlotForThisNumber(WhichNumber) = 1
  Next WhichNumber
 
  Do
    'Exit loop if all entries in SlotForThisNumber are 3
    x = 0
    For WhichNumber = 1 To CountOfNumbers
      x = x + SlotForThisNumber(WhichNumber)
    Next WhichNumber
    If x = CountOfNumbers * 3 Then Exit Do
   
    'Increase number of combinations and expand the Slots array
    Counter = Counter + 1
    ReDim Preserve Slots(1 To 3, 1 To CountOfNumbers, 1 To Counter)
   
    'Clear the number of entries in each Slot
    For SlotNumber = 1 To 3
      CountOfNumbersInSlot(SlotNumber) = 0
    Next SlotNumber

    'Loop through all numbers from 1 to CountOfNumbers
    For WhichNumber = 1 To CountOfNumbers
      SlotNumber = SlotForThisNumber(WhichNumber)
      CountOfNumbersInSlot(SlotNumber) = CountOfNumbersInSlot(SlotNumber) + 1
      SlotRowNumber = CountOfNumbersInSlot(SlotNumber)
      Slots(SlotNumber, SlotRowNumber, Counter) = Numbers(WhichNumber - 1)
    Next WhichNumber
   
    'Clear the Slots array for the last combination
    'and decrease Counter with 1 if any slots are empty
    For SlotNumber = 1 To 3
      If CountOfNumbersInSlot(SlotNumber) = 0 Then
        For SlotRowNumber = 1 To CountOfNumbers
          Slots(1, SlotRowNumber, Counter) = 0
          Slots(2, SlotRowNumber, Counter) = 0
          Slots(3, SlotRowNumber, Counter) = 0
        Next SlotRowNumber
        Counter = Counter - 1
        Exit For
      End If
    Next SlotNumber
   
    'Increase SlotForThisNumber counters
    SlotForThisNumber(CountOfNumbers) = SlotForThisNumber(CountOfNumbers) + 1
    For WhichNumber = CountOfNumbers To 2 Step -1
      If SlotForThisNumber(WhichNumber) = 4 Then
        SlotForThisNumber(WhichNumber) = 1
        SlotForThisNumber(WhichNumber - 1) = SlotForThisNumber(WhichNumber - 1) + 1
      End If
    Next WhichNumber
  Loop
 
  'Now, let's see the list
  Debug.Print "List of possible combinations:"
  For x = 1 To Counter
    Debug.Print "Combination #"; x
    For SlotRowNumber = 1 To CountOfNumbers
      If (Slots(1, SlotRowNumber, x) + Slots(2, SlotRowNumber, x) + Slots(3, SlotRowNumber, x)) <> 0 Then
        For SlotNumber = 1 To 3
          Debug.Print Slots(SlotNumber, SlotRowNumber, x),
        Next SlotNumber
        Debug.Print
      End If
    Next SlotRowNumber
  Next x
End Sub

/Ture
0
 
LVL 22

Expert Comment

by:ture
ID: 2372806
*******************************************************************
0
 
LVL 1

Expert Comment

by:cvidler
ID: 2376692
what exactly are you trying to do. What will your program be used for - maybe I'll beable to give you a solution if I know what's going to happen with the results?
0
 

Author Comment

by:Psycho1
ID: 2380616
ture:

It's PERFECT! Thank You very much! You've saved my life! These points are yours!

0
 

Author Comment

by:Psycho1
ID: 2380619
Thanks again...
0

Featured Post

Never miss a deadline with monday.com

The revolutionary project management tool is here!   Plan visually with a single glance and make sure your projects get done.

Question has a verified solution.

If you are experiencing a similar issue, please ask a related question

If you have ever used Microsoft Word then you know that it has a good spell checker and it may have occurred to you that the ability to check spelling might be a nice piece of functionality to add to certain applications of yours. Well the code that…
You can of course define an array to hold data that is of a particular type like an array of Strings to hold customer names or an array of Doubles to hold customer sales, but what do you do if you want to coordinate that data? This article describes…
Get people started with the process of using Access VBA to control Excel using automation, Microsoft Access can control other applications. An example is the ability to programmatically talk to Excel. Using automation, an Access application can laun…
This lesson covers basic error handling code in Microsoft Excel using VBA. This is the first lesson in a 3-part series that uses code to loop through an Excel spreadsheet in VBA and then fix errors, taking advantage of error handling code. This l…
Suggested Courses

601 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question