Permutations

[howard]

I have a series of numbers in an excel spreadsheet for eg 6, 11,7,28,23,28,45,47,41,35,38
where I want to determine the number permutations.

The criteria is as follows:

1) The maximum number number in any row/cell is 6 for eg 1, 18, 23, 38, 45, 49

2) No number must occur more than once in a cell for eg the number 11, 11 must now be allowed


It would be appreciated if you would provide me wth VBA code that will allow me to do the above

Once the Macro has been activated the data should look similar to this

11, 7, 17, 28, 23, 28
11, 7, 17, 28, 23, 45
11, 7, 17, 28, 23, 47

Howard

 

[GlennUK]

And which 15 out of 0.3 millions possibilities? How is Ravi supposed to decide that?

 

[ravishankar]

Hi
I have written a macro where I used random numbers to shuffle your list. But I notice many repeat numbers. Programs are available on the net to generate permutations. I could not figure out how to use them. I am planning to modify this macro so that it picks up only the list of non-repeats. Hope to be ready by sunday
Ravi

 

[GlennUK]

Well done Ravi ... I hope that's what the OP wants.

 

[ravishankar]

HI
List your numbers from A1: A12

paste the following codes in the macro window ( alt F8)

Sub rrr()
For e = 3 To 17
For a = 3 To 8
c = Int((12 * Rnd) + 1)
Cells(1, a) = Cells(c, 1)
Next a
For b = 3 To 8
Cells(1, 10) = "=countif(A3:A8,A" & b & ")"
If Cells(1, 10) > 1 Then
Else
Cells(e, 2) = "Permutations # " & e - 2
For d = 3 To 8
Cells(e, d) = Cells(1, d)
Next d
End If
Next b
Next e
Range("C1:J1").ClearContents
End Sub

run the macro.
you wil get 15 permutations of 12 numbers six at a time.

Ravi

 

[howard]

Hi Ravi

Thanks for the code. I entered 12 numbers in cells A1:A12. 15 permutations were extracted containing 6 numbers each. Some of the rows contained duplicate numbers i.e amongst the 6 numbers there were duplicate numbers for eg
43 38 38 23 23 44

The numbers per row of 6 numbers must be uniqie.

I have attached the file after running the macro and have highlighted the duplicate numbers. Kindly amend your Macro so that the 6 numbers er row are unique.

Kind Regards

Howard

Permutations.Macro.xls
	A	B	C	D	E	F	G	H	I
1	1
2	11
3	14	Permutations#1	43	38	38	23	23	44
4	23	Permutations#2	1	44	44	43	1	28
5	28	Permutations#3	47	44	28	48	47	1
6	31	Permutations#4	48	28	38	44	1	40
7	38	Permutations#5	31	23	40	40	23	23
8	40	Permutations#6	44	44	40	48	47	14
9	43	Permutations#7	43	48	14	38	11	48
10	44	Permutations#8	43	1	38	11	11	44
11	47	Permutations#9	23	1	23	28	23	48
12	48	Permutations#10	48	28	23	11	11	40
13		Permutations#11	28	28	43	23	40	14
14		Permutations#12	14	40	1	31	47	23
15		Permutations#13	44	28	23	48	40	40
16		Permutations#14	31	11	38	43	47	47
17		Permutations#15	1	38	47	31	43	38
18
Sheet1

 

[mikerickson]

Put as many values as you like in column A.
Run this macro and a random selection of those values (without duplicates) will be shown.
(caveat: if there are duplicates in column A, that might be refelected in dupliates in the permiutations shown.)

Sub permiutation()
Dim selectFrom As Variant, i As Integer, howMany As Integer, thisIndex As Integer
Dim numOfPerm, k As Integer
Dim xRay As Range, xCell As Range
Set xRay = Range(ActiveSheet.Range("a1"), ActiveSheet.Range("a65536").End(xlUp))

numOfPerm = Application.InputBox("how many permiutations do you want to see?", Type:=1)
If numOfPerm = False Then Exit Sub
numOfPerm = Int(numOfPerm)
If numOfPerm < 1 Then Exit Sub

howMany = Application.InputBox("how many elements in each permiutation?", Type:=1)
If howMany = False Then Exit Sub
howMany = Int(howMany)
If howMany < 1 Then Exit Sub

Range(Cells(1, 2), Cells(1, i + numOfPerm)).EntireColumn.ClearContents
For k = 1 To numOfPerm
    selectFrom = Application.Transpose(xRay)
    ReDim Preserve selectFrom(1 To UBound(selectFrom) + 1)


    For i = 1 To howMany
    
        thisIndex = Int(Rnd() * UBound(selectFrom)) + 1
        Cells(i, 1 + k).Value = selectFrom(thisIndex)
        For j = thisIndex To (UBound(selectFrom) - 1)
            selectFrom(j) = selectFrom(j + 1)
        Next j
        ReDim Preserve selectFrom(1 To UBound(selectFrom) - 1)
    
    Next i
Next k
End Sub

 

[howard]

Permuatation.1.xls
	A	B	C	D	E	F	G	H	I	J	K	L	M	N	O	P
1	1	44	1	48		38	47	44	43	23		31	14	47	31	1
2	11	38	47	44	28	23	44		1	1	28	28	43	28	11	40
3	14	40	44	28	38	43	38	14	40	31	23	44	1	23	43
4	23	14	43		44	44		38	14	38	11	23	38		44	31
5	28	23	11	43	1	14	48	1	11	28	14	43		40		44
6	31	48	31	1	40	28	11	48	48		44	11	28	43	47	38
7	38
8	40
9	43
10	44
11	47
12	48
Sheet1

 

[howard]

permutations

Hi mikerickson

Thanks for your code. It is working almost perfectly. I entered 12 numbers into cells A1:A12 and activated the macro. The number of permutations required in this case was 15, containing 6 numbers.

15 permutations were extracted. In most instances 6 unique numbers were extracted, in some cases 5 numbers and one blank cell.

I have attached my file so that you can see what was extracted.

It would be appreciated if you would amend your code so that unique numbers are extracted for the number of elements required in this eg 6 elements were required


Your assistance will be most appreciated.

Regards

Howard

 

[mikerickson]

I think this is better than my last suggestion.
This will write the permiutations in rows, beginining at C2 of ThisWorkbook.Sheets(1).

Option Explicit

Sub testTwo()
Dim i As Integer, j As Integer
Dim temp As Variant
Dim deflt As String
Static elementsPerChoice As Integer
Static numChoicesMade As Integer
Static elementsRay As Range

Dim selectFrom As Variant
Dim randIndex As Integer, maxIndex As Integer
Dim writeRay As Range

Rem get elements
    Rem input range
        If Not (elementsRay Is Nothing) Then _
        deflt = elementsRay.Address
        On Error Resume Next
        Set elementsRay = Application.InputBox _
                            ("Select the elements to permute.", _
                                Default:=deflt, _
                                Type:=8)
        If TypeName(elementsRay) <> "Range" Then Exit Sub
        On Error GoTo 0
        If Not (elementsRay.Rows.Count = 1 _
            Or elementsRay.Columns.Count = 1) _
            Then Beep: Exit Sub
    
    Rem range to array
        If elementsRay.Columns.Count = 1 Then
            selectFrom = Application.Transpose(elementsRay)
        Else
            Rem array handeling for my environment
            selectFrom = Application.Transpose(Application.Transpose(elementsRay))
        End If

Rem how many elements per choice
    If elementsPerChoice = 0 Then elementsPerChoice = 6
    deflt = CStr(elementsPerChoice)
    elementsPerChoice = Application.InputBox( _
                                "How many elements in each choice?", _
                                Default:=deflt, Type:=1)
    If elementsPerChoice = False Then Exit Sub
    If elementsPerChoice > elementsRay.Cells.Count Then _
                    elementsPerChoice = elementsRay.Cells.Count

Rem - - - - - - -Begin Edit  - - - - - - - - - - - - - - -

Rem input how many to show and length of permiutation
    If numChoicesMade = 0 Then numChoicesMade = 15
    If elementsPerChoice = 0 Then elementsPerChoice = 6
    deflt = CStr(numChoicesMade) & ", " & CStr(elementsPerChoice)

    Do
        temp = Application.InputBox( _
                    prompt:="Enter the number of choices to display and" _
                    & vbCrLf & vbTab & "the number of elements in each choice," _
                    & vbCrLf & vbTab & vbTab & "separated by a comma." _
                    & vbCrLf & vbCrLf & vbTab & "rows_displayed , elements_per_row", _
                    Default:=deflt, _
                    Type:=2)
        If temp = "False" Then Exit Sub
        On Error Resume Next
        j = Application.Search(",", temp, 2)
        On Error GoTo 0
    Loop Until j > 0

    numChoicesMade = Val(temp)
    elementsPerChoice = Val(Mid(temp, j + 1))
    If elementsPerChoice > elementsRay.Cells.Count Then _
        elementsPerChoice = elementsRay.Cells.Count

Rem where to start writing
    Set writeRay = ThisWorkbook.Sheets(1).Range("c2")
    Set writeRay = Range(writeRay, writeRay.Cells(1, elementsPerChoice))

Rem - - - - - - begin New Edit - see post below - - - - - - -

Application.Calculation = xlManual
    
Rem - - - - - - - - - -End Edit - - - - - - - - - - - - - - - - 
Rem main routine
    For j = 1 To numChoicesMade
    
        Rem randomly reorder selectFrom
        maxIndex = UBound(selectFrom)
        For i = 1 To elementsPerChoice
            randIndex = Int(Rnd() * maxIndex) + 1
            temp = selectFrom(randIndex)
            selectFrom(randIndex) = selectFrom(i)
            selectFrom(i) = temp
            Rem maxIndex = maxIndex - 1 (not needed)
        Next i
        
        Rem show the first n elements of that re-ordering
        writeRay.Offset(j - 1, 0).Value = selectFrom
    
    Next j
End Sub

 

[ravishankar]

Hi
I am surprised at your output. I used to get it like that before I introduced countif function to check for duplicates. Now I have repeatedly checked but don't find any duplicates. I suggest you copy the macro and run it again. If you still have problems, I will fix it.
Ravi