Permutation VBA correction

[vergab]

Hi,
Could someone help me to convert this code as follows?
Write the permutation of the items listed in column 'A' to separate columns.
I would like to use it as shown in the example.

Sample:

Items			Result
1			1	2	3	A
2			1	2	A	3
3			1	3	2	A
A			1	3	A	2
			1	A	2	3
			1	A	3	2
			2	1	3	A
			2	1	A	3
			2	3	1	A
			2	3	A	1
			2	A	1	3
			2	A	3	1
			3	1	2	A
			3	1	A	2
			3	2	1	A
			3	2	A	1
			3	A	1	2
			3	A	2	1
			A	1	2	3
			A	1	3	2
			A	2	1	3
			A	2	3	1
			A	3	1	2
			A	3	2	1

<tbody>
</tbody>

Code:

Option Explicit
Option Compare Text
Dim CurrentRow
Sub DoString()
On Error Resume Next
Dim Instring As String
Dim i As Integer, j As Integer
Instring = Range("A1").Value
Range("A1").Select
CurrentRow = 1
Call GetPermutation("", Instring)
TxToCoL
End Sub

Sub GetPermutation(X As String, y As String)
On Error Resume Next
Dim j, i
j = Len
If j < 2 Then
Cells(CurrentRow, 1) = X & y
CurrentRow = CurrentRow + 1
Else
For i = 1 To j
Call GetPermutation(X + Mid(y, i, 1), _
Left(y, i - 1) + Right(y, j - i))
Next
End If
End Sub
Sub TxToCoL()
'Range("A1:A" & Range("A" & Rows.Count).End(xlUp).Row).Select
Range("A1:A40320").Select
Selection.TextToColumns Destination:=Range("D1"), DataType:=xlFixedWidth, _
FieldInfo:=Array(Array(1, 1), Array(2, 1), Array(3, 1), Array(4, 1), Array _
(5, 1), Array(6, 1), Array(7, 1), Array(8, 1), Array(9, 1)), _
TrailingMinusNumbers:=True
End Sub

 

[WarPigl3t]

I've never done this before. Challenge accepted!

Sub myPermutation ()
     itemsColumn = 1
     resultColumn = 2
     firstRow = 2
     lastRow = Cells(Rows.Count, itemsColumn).End(xlUp).Row
     
     Dim itemsArray() As String
     a = 0
     ReDim Preserve itemsArray(a)
     r = firstRow
     Do Until r > lastRow
          itemValue = Cells(r, itemsColumn).Value
          ReDim Preserve itemsArray(a)
          itemsArray(a) = itemValue
          a = a + 1
          r = r + 1
     Loop
     If itemsArray(0) = "" _
     And UBound(itemsArray) = 1 Then
          End
     End If
     r = firstRow
     Call generatePermuatations(a, itemsArray, resultColumn, r)
End Sub
Sub generatePermutations(n, A, resultColumn, r)
     printRow = Cells(Rows.Count, resultColumn).End(xlUp).Row + 1
     If printRow < r Then 
          PrintRow = r
     End If
     If n = 1 Then
          For Each element In A
               Cells(printRow, resultColumn).Value = element
               resultColumn = resultColumn + 1
          Next element
          End
     End If
     i = 0
     Do Until i < n - 1
          Call generatePermutations(n - 1, A, resultColumn, r)
          If IsEven(n) Then
               myMove = A(i)
               A(i) = A(n - 1)
               A(n - 1) = myMove
          Else
               myMove = A(0)
               A(0) = A(n - 1)
               A(n - 1) = myMove
          End If
          printRow = Cells(Rows.Count, resultColumn).End(xlUp).Row + 1
          resultC = resultColumn
          For Each element In A
               Cells(printRow, resultColumn).Value = element
               resultC = resultC + 1
          Next element
          i = i + 1
     Loop
     generatePermutations(n - 1, A, resultColumn, r)
End Function

I'm 99% sure this won't work. This is my attempt to translate Heap's algorithm from pseudocode to VBA.

 

[ProgramUser]

Nice effort WarPig....!!! Good work.

Vergab, you can NOT go wrong with PGC01's code....

Follow this link from within this forum;
http://www.mrexcel.com/forum/excel-...c-applications-combinations-permutations.html

I have used it over the years with great success thanks to PGC01 and have munched it, altered it, loved it, and on occasion hated It! Good luck with it.... Be sure to restrict your output to less than 7 items chosen (or 8) elements with a subset less than 20.....otherwise you'll crash VBA (Excel) unless you own and operate a supercomputer!

Regards,

P.U.

 

[vergab]

It stopped in the row "Call generatePermutations" with error message:

"Compile error: Sub or Function not defined"

 

[vergab]

PGC01's code isn't permutation. Permutation result must be "n!" if there are "n" different items.

 

[wideboydixon]

I've been looking at this. Here's the sheet I have:

Book1
	A	B	C	D	E	F	G	H	I	J	K
1	Items		Results					Results
2	a		a	b	c	d		a	b	c	d
3	b		b	a	c	d		a	b	d	c
4	c		c	a	b	d		a	c	b	d
5	d		a	c	b	d		a	c	d	b
6			b	c	a	d		a	d	b	c
7			c	b	a	d		a	d	c	b
8			d	b	a	c		b	a	c	d
9			b	d	a	c		b	a	d	c
10			a	d	b	c		b	c	a	d
11			d	a	b	c		b	c	d	a
12			b	a	d	c		b	d	a	c
13			a	b	d	c		b	d	c	a
14			a	c	d	b		c	a	b	d
15			c	a	d	b		c	a	d	b
16			d	a	c	b		c	b	a	d
17			a	d	c	b		c	b	d	a
18			c	d	a	b		c	d	a	b
19			d	c	a	b		c	d	b	a
20			d	c	b	a		d	a	b	c
21			c	d	b	a		d	a	c	b
22			b	d	c	a		d	b	a	c
23			d	b	c	a		d	b	c	a
24			c	b	d	a		d	c	a	b
25			b	c	d	a		d	c	b	a
Sheet1

Cell Formulas
Range	Formula
H2	=GetPermutation($A$2:$A$5, ROW() - 1, COLUMN() - 7)

And here's the code I was using:

Private savedCount As Long
Private savedOutput() As String
Private Sub GetPermutations(permString As String, currentSelection As String, ByRef currentResult As String)

Dim i As Long

If permString = "" Then
    currentResult = currentResult & IIf(currentResult = "", "", ",") & currentSelection
    Exit Sub
End If

For i = 1 To Len(permString)
    GetPermutations Left$(permString, i - 1) & Mid$(permString, i + 1), currentSelection & Mid$(permString, i, 1), currentResult
Next i

End Sub
Public Function GetPermutation(sourceRange As Range, permNumber As Long, indexNumber As Long) As String

Dim rangeCount As Long
Dim permOutput As String

rangeCount = sourceRange.Count

If permNumber < 1 Or permNumber > WorksheetFunction.Permut(rangeCount, rangeCount) _
Or indexNumber < 1 Or indexNumber > rangeCount Then
    GetPermutation = ""
    Exit Function
End If

If rangeCount <> savedCount Then
    savedCount = rangeCount
    permOutput = ""
    GetPermutations Left$("123456789", savedCount), "", permOutput
    savedOutput = Split(permOutput, ",")
End If

GetPermutation = sourceRange(CLng(Mid$(savedOutput(permNumber - 1), indexNumber, 1))).Value

End Function
Public Sub GeneratePermutations(n As Long, a() As String, r As Long, c As Long)

Dim i As Long
Dim t As String

If n = 1 Then
    For i = 0 To UBound(a)
        Cells(r, c + i).Value = a(i)
    Next i
    r = r + 1
Else
    For i = 0 To n - 2
        GeneratePermutations n - 1, a, r, c
        If n Mod 2 = 0 Then
            t = a(i)
            a(i) = a(n - 1)
            a(n - 1) = t
        Else
            t = a(0)
            a(0) = a(n - 1)
            a(n - 1) = t
        End If
    Next i
    GeneratePermutations n - 1, a, r, c
End If

End Sub
Sub GenerateAllPermutations()

Dim i As Long
Dim s As Range
Dim t As Range
Dim c As Long
Dim r As Long

Set s = Range("$A$2:$A$5")
Set t = Range("$C$2")

ReDim a(s.Count - 1) As String

For i = 1 To s.Count
    a(i - 1) = s(i).Value
Next i

r = t.Row
c = t.Column

GeneratePermutations s.Count, a, r, c

End Sub

Cells C2:F25 were populated by calling GenerateAllPermutations() in which you can see I've defined the source and target ranges.
Cells H2:K25 are populated using a formula (in H2) which you can copy across and down. Note that the formula has a correction factor on the ROW() and COLUMN() which you may need to change if you move it elsewhere. You could change it to:

=GetPermutation($A$2:$A$5, ROW() - ROW($H$2) + 1, COLUMN() - COLUMN($H$2) + 1)

Which might help if you cut and paste it somewhere else.

The GenerateAllPermutations() macro uses a VBA implementation of Heap's algorithm. The UDF is something I knocked together myself that uses caching so it doesn't generate all permutations each time.

These may be useful to you but in the main I just took this on as an interesting exercise

WBD

 

[vergab]

It works! How will change the code if I want to write not only 5 but any quantity of items in column A?