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

 

[twinetwstr]

The function MRAND(6,1,12) in the MOREFUNC package should do the trick here, but I can't get it to work. Has anyone used this function? I did use the CTRL-SHIFT-ENTER to enter the function in a cell, but I get a NumberError. I get the error even when using the examples in the Morefunc Help page.

 

[mikerickson]

If you are selecting N items many times, this new edit will make things faster.
If you are doing truly massive numbers of selections (10,000+ choices, showing 15+ elements per choice) this will run into memory issues and the current one is better (after numChoicesMade is dimensioned Long). But if you are below that number, this speeds things up in the 200 - 10,000 choice range.

Rem - - - - - - begin New Edit - - - - - - - - - - -

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

Dim outputRRay As Variant
ReDim outputRRay(1 To numChoicesMade, 1 To elementsPerChoice)

Application.Calculation = xlManual
Application.ScreenUpdating = False

Rem permutation  routine
    For j = 1 To numChoicesMade
    
    Rem randomly re-order selectFrom
        maxIndex = UBound(selectFrom) + 1
        For i = 1 To elementsPerChoice
            randIndex = i + Int(Rnd() * (maxIndex - i))
            
            temp = selectFrom(randIndex)
            selectFrom(randIndex) = selectFrom(i)
            selectFrom(i) = temp
            
            outputRRay(j, i) = selectFrom(i)
        Next i
        
    Next j
    writeRay.Value = outputRRay
    
Application.ScreenUpdating = True
Application.Calculation = xlAutomatic

End Sub

 

[howard]

Hi mikerickson

Thanks for the help. I will use your latest code.

Kind regards

Howard

 

[CARBOB]

Help With Macro

I found this Macro on the forum and I want to know if it will work for what I need. In Col A, I have 3 sets of numbers. I want to create all the different Combinations or Permutation with only 5 in a row, likethe ones in Col's C to G. I know very little Excel and nothing about Macros. Thanks for all suggestions.

PERMUTATIONS.xls
	A	B	C	D	E	F	G	H	I
1	300		300	300	300	300	300
2	201		201	201	201	201	201
3	102		102	102	102	102	102
4			300	300	300	300	201
5
6
7
8
Sheet1

If you are selecting N items many times, this new edit will make things faster.
If you are doing truly massive numbers of selections (10,000+ choices, showing 15+ elements per choice) this will run into memory issues and the current one is better (after numChoicesMade is dimensioned Long). But if you are below that number, this speeds things up in the 200 - 10,000 choice range.

Rem - - - - - - begin New Edit - - - - - - - - - - -

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

Dim outputRRay As Variant
ReDim outputRRay(1 To numChoicesMade, 1 To elementsPerChoice)

Application.Calculation = xlManual
Application.ScreenUpdating = False

Rem permutation  routine
    For j = 1 To numChoicesMade
    
    Rem randomly re-order selectFrom
        maxIndex = UBound(selectFrom) + 1
        For i = 1 To elementsPerChoice
            randIndex = i + Int(Rnd() * (maxIndex - i))
            
            temp = selectFrom(randIndex)
            selectFrom(randIndex) = selectFrom(i)
            selectFrom(i) = temp
            
            outputRRay(j, i) = selectFrom(i)
        Next i
        
    Next j
    writeRay.Value = outputRRay
    
Application.ScreenUpdating = True
Application.Calculation = xlAutomatic

End Sub

 

[mikerickson]

No, it won't. The routine that you found forbids duplicates in the result. Your problem requires duplicates.

 

[jindon]

try

Sub test()
Dim a, i As Long, ii As Long, b(1 To 15, 1 To 7)
a = Range("a1",Range("a" & Rows.Count).End(xlUp)).Resize(,2).Value
Randomize
For i = 1 To 15
     For ii = 1 To UBound(a,1) : a(ii,2) = Rnd : Next
     VSortMA a, 1, UBound(a,1), 2
     b(i,1) = "Permutations#" & i
     For ii = 2 To 7 : b(i,ii) = a(ii - 1, 1) : Next
Next
Range("b1").Resize(15,7).Value = b
End Sub

Private Sub VSortMA(ary, LB, UB, ref)
Dim M As Variant, i As Long, ii As Long, iii As Long, temp '<- this line
i = UB : ii = LB  '<- this line
M = ary(Int((LB+UB)/2),ref)
Do While ii <= i
     Do While ary(ii, ref) < M
          ii = ii + 1
     Loop
     Do While ary(i, ref) > M
          i = i - 1
     Loop
     If ii <= i Then
          For iii = LBound(ary, 2) To UBound(ary, 2)
               temp = ary(ii,iii) : ary(ii,iii) = ary(i,iii) : ary(i,iii) = temp
          Next
          ii = ii + 1 : i = i - 1
     End If
Loop
If LB < i Then VSortMA ary, LB, i, ref
If ii < UB Then VSortMA ary, ii, UB, ref
End Sub

 

[CARBOB]

I get a Complie Error, "Duplicate Declaration in Current Scope" . The macro stops


Private Sub VSortMA(ary, LB, UB, ref)Dim M As Variant, i As Long, ii As Long, iii As Long, ref, temp
i = UB: ii = UB
M = ary(Int((LB + UB) / 2), ref)
Do While ii <= i
Do While ary(ii, ref) < M
ii = ii + 1
Loop
Do While ary(i, ref) > M
i = i - 1
Loop
If ii <= i Then
For iii = LBound(ary, 2) To UBound(ary, 2)
temp = ary(ii, iii): ary(ii, iii) = ary(i, iii): ary(i, iii) = temp
Next
ii = ii + 1: i = i - 1
End If
Loop
If LB < i Then VSrotMA ary, LB, i, ref
If ii < UB Then VSortMA ary, ii, UB, ref
End Sub

try

Sub test()
Dim a, i As Long, ii As Long, b(1 To 15, 1 To 7)
a = Range("a1",Range("a" & Rows.Count).End(xlUp)).Resize(,2).Value
Randomize
For i = 1 To 15
     For ii = 1 To UBound(a,1) : a(ii,2) = Rnd : Next
     VSortMA a, 1, UBound(a,1), 2
     b(i,1) = "Permutations#" & i
     For ii = 2 To 7 : b(i,ii) = a(ii - 1, 1) : Next
Next
Range("b1").Resize(15,7).Value = b
End Sub

Private Sub VSortMA(ary, LB, UB, ref)
Dim M As Variant, i As Long, ii As Long, iii As Long, ref, temp
i = UB : ii = UB
M = ary(Int((LB+UB)/2),ref)
Do While ii <= i
     Do While ary(ii, ref) < M
          ii = ii + 1
     Loop
     Do While ary(i, ref) > M
          i = i - 1
     Loop
     If ii <= i Then
          For iii = LBound(ary, 2) To UBound(ary, 2)
               temp = ary(ii,iii) : ary(ii,iii) = ary(i,iii) : ary(i,iii) = temp
          Next
          ii = ii + 1 : i = i - 1
     End If
Loop
If LB < i Then VSrotMA ary, LB, i, ref
If ii < UB Then VSortMA ary, ii, UB, ref
End Sub

 

[jindon]

In the Dim statement "ref" must be deleted and

i = UB : ii = UB

Shold be

i = UB : ii = LB

code has been edited

 

[CARBOB]

Thanks for responding.

Now it stops here


Private Sub VSortMA(ary, LB, UB, ref)
Dim M As Variant, i As Long, ii As Long, iii As Long, ref, temp
i = UB: ii = UB
M = ary(Int((LB + UB) / 2), ref)
Do While ii <= i
Do While ary(ii, ref) < M
ii = ii + 1
Loop
Do While ary(i, ref) > M
i = i - 1
Loop
If ii <= i Then
For iii = LBound(ary, 2) To UBound(ary, 2)
temp = ary(ii, iii): ary(ii, iii) = ary(i, iii): ary(i, iii) = temp
Next
ii = ii + 1: i = i - 1
End If
Loop
If LB < i Then VSrotMA ary, LB, i, ref
If ii < UB Then VSortMA ary, ii, UB, ref
End Sub

 

[jindon]

Have you read my previous post carefully?

Anyway, I have edited the code already...