Option Explicit
Sub Rn()
Dim a$, b&, i&, c&(), d$(), j&, k&, r&, e$()
a = "ABCDEFGH"
Application.Calculation = xlCalculationManual: Application.ScreenUpdating = False
b = Len(a): ReDim d(1 To b): ReDim e(0)
For i = 1 To b: d(i) = Right(Left(a, i), 1): Next i
For i = 1 To b
c = PerN(b, i): ReDim Preserve e(r + UBound(c))
For j = 1 To UBound(c)
e(r + j) = d(c(j, 1))
For k = 2 To UBound(c, 2): e(r + j) = e(r + j) & d(c(j, k)): Next k
Next j
r = UBound(e)
Next i
Sheets.Add
For i = 1 To UBound(e): Cells(i, 1) = e(i): Next i
Application.Calculation = xlCalculationAutomatic: Application.ScreenUpdating = True
End Sub
Function PerN(ByVal a&, ByVal b&) As Long() 'permutations
Dim Tc&(), Tp&(), Uc&, Up&, c&, t&, r&, i&, j&, k&, ii&
Tc = CmbN(a, b): Uc = UBound(Tc): Up = FacL(a, b): ReDim Tp(1 To Up, 1 To b)
For i = 1 To Uc: For j = 1 To b: Tp(i, j) = Tc(i, j): Next j, i
Erase Tc: c = Uc
For ii = 1 To b - 1
r = c
For i = 1 To r
ReDim Tc(ii To b)
For j = ii To b: Tc(j) = Tp(i, j): Next j
For j = 1 To b - ii
c = c + 1: t = Tc(ii)
For k = 1 To ii - 1: Tp(c, k) = Tp(i, k): Next k
For k = ii To b - 1: Tp(c, k) = Tc(k + 1): Next k
Tp(c, b) = t
If j < b - ii Then
For k = ii To b: Tc(k) = Tp(c, k): Next k
End If
Next j
Next i
Next ii
PerN = Tp
End Function
Function CmbN(ByVal a&, ByVal b&) As Long() 'combinaisons(a,b)
Dim n&, Tb&(), c&, i&, j&
n = CmbNb(a, b): ReDim Tb(1 To n, 1 To b): c = a - b
For i = 1 To b: Tb(1, i) = i: Next i
For i = 2 To n
If b = 1 Then Tb(i, 1) = Tb(i - 1, 1) + 1 Else Tb(i, 1) = Tb(i - 1, 1) - (Tb(i - 1, 2) = c + 2)
For j = 2 To b - 1
If Tb(i - 1, j + 1) = c + j + 1 Then
If Tb(i - 1, j) = c + j Then Tb(i, j) = Tb(i, j - 1) + 1 Else Tb(i, j) = Tb(i - 1, j) + 1
Else
Tb(i, j) = Tb(i - 1, j)
End If
Next j
If Tb(i - 1, b) = a Then Tb(i, b) = Tb(i, b - 1) + 1 Else Tb(i, b) = Tb(i - 1, b) + 1
Next i
CmbN = Tb
End Function
Function CmbNb(ByVal a&, ByVal b&) As Long 'nb combinaisons(a,b)
Dim c&
c = a - b
If c = 0 Then
CmbNb = 1
Else
If b < c Then c = b
CmbNb = FacL(a, c) / FacL(c)
End If
End Function
Function FacL(ByVal a&, Optional b) As Long 'factorielle (option nb itérations)
Dim i&, c&
If Not IsMissing(b) Then c = CLng(b) Else c = a
If a = 0 Or c = 0 Then FacL = 1: Exit Function
FacL = a
For i = 2 To c: FacL = FacL * (a - i + 1): Next i
End Function
