Hi faditaouk, welcome to the board.I need a set of formulas to list all 720 permutations of the numbers 1,2,3,4,5,6, if it can't be done by a formula then it has to be in macro. May anyone help!
Sub Permutations_6_From_6()
Dim rRng As Range
Dim lRow As Long
With Application
.ScreenUpdating = False: .Calculation = xlCalculationManual: .DisplayAlerts = False
End With
Range("C:H").ClearContents
Set rRng = Range("A1", Range("A1").End(xlDown))
For P1 = 1 To rRng.Count
For P2 = 1 To rRng.Count
For P3 = 1 To rRng.Count
For P4 = 1 To rRng.Count
For P5 = 1 To rRng.Count
For P6 = 1 To rRng.Count
If _
P1 <> P2 And _
P1 <> P3 And _
P1 <> P4 And _
P1 <> P5 And _
P1 <> P6 And _
P2 <> P3 And _
P2 <> P4 And _
P2 <> P5 And _
P2 <> P6 And _
P3 <> P4 And _
P3 <> P5 And _
P3 <> P6 And _
P4 <> P5 And _
P4 <> P6 And _
P5 <> P6 Then
lRow = lRow + 1
Range("C" & lRow) = Range("A" & P1)
Range("D" & lRow) = Range("A" & P2)
Range("E" & lRow) = Range("A" & P3)
Range("F" & lRow) = Range("A" & P4)
Range("G" & lRow) = Range("A" & P5)
Range("H" & lRow) = Range("A" & P6)
End If
Next P6
Next P5
Next P4
Next P3
Next P2
Next P1
Range("A1").Select
With Application
.DisplayAlerts = True: .Calculation = xlCalculationAutomatic: .ScreenUpdating = True
End With
End Sub
Option Explicit
Sub permute()
Const num As Integer = 6
Dim i As Integer, j As Integer, iCount As Integer
Dim K As Integer, L As Integer
Dim foundK As Boolean
Dim arrResults()
ReDim arrResults(1 To num, 1 To 1)
Dim arrTempResults()
ReDim arrTempResults(1 To num, 1 To 1)
' generate first permutation
For j = 1 To num
arrResults(j, 1) = j
Next j
nextLoop:
iCount = iCount + 1
' 1.Find the largest index k such that a[k] < a[k + 1]. If no such index exists, the permutation is the last permutation.
foundK = False
For j = num To 2 Step -1
If arrResults(j, iCount) > arrResults(j - 1, iCount) Then
K = j - 1
foundK = True
Exit For
End If
Next j
If Not foundK Then GoTo algorithmEnd
' 2.Find the largest index l greater than k such that a[k] < a[l].
For j = K To num
If arrResults(j, iCount) > arrResults(K, iCount) Then L = j
Next j
' 3.Swap the value of a[k] with that of a[l].
For j = 1 To num
arrTempResults(j, 1) = arrResults(j, iCount)
Next j
arrTempResults(K, 1) = arrResults(L, iCount)
arrTempResults(L, 1) = arrResults(K, iCount)
' 4.Reverse the sequence from a[k + 1] up to and including the final element a[n].
ReDim Preserve arrResults(1 To num, 1 To iCount + 1)
Debug.Print K, L, "/", arrTempResults(1, 1), arrTempResults(2, 1), arrTempResults(3, 1), arrTempResults(4, 1)
For j = 1 To K
arrResults(j, iCount + 1) = arrTempResults(j, 1)
Next j
For j = K + 1 To num
arrResults(j, iCount + 1) = arrTempResults(num - j + K + 1, 1)
Next j
' error prevention during test:
'If iCount = 24 Then GoTo algorithmEnd
GoTo nextLoop
algorithmEnd:
Range("A1").Resize(UBound(arrResults, 1), UBound(arrResults, 2)) = arrResults
End Sub
Great solution XOR LX. I'll keep that in mind for timesaving solutions, avoiding array formulas.
2 Suggestions:
1. Start by entering the complete formula (so the last one). While in the formula bar, put the cursor after the first parenthesis, click "array" in the popup below (the one for INDEX syntax), press F9 (wait a moment) and Enter.
2. The resulting formula is 5000+ characters, so this would be the maximum possible number of permutations achievable with this formula; in other words 1-7 would result in a formula exceeding the limit of 8192 characters.
=INDEX(#NAME?,ROWS($1:1))