Dim a() As Integer

Sub GeneratePermutations()

     Dim obs As Integer, n As Integer, j As Long
      
     n = 6 'количество элементов
      
     'управление основанием массива a(): либо от 0 до n-1, либо от 1 до n
     obs = 1 'здесь можно задать либо 0, либо 1 (а-ля Option Base)
         
     'начальная расстановка: элементы = натуральные числа от 1 до N по возрастанию
     Select Case obs
         Case 0:
             ReDim a(0 To n - 1): For j = 0 To n - 1: a(j) = j + 1: Next j
         Case 1:
             ReDim a(1 To n):     For j = 1 To n:     a(j) = j:     Next j
     End Select
     'следующую строку раскомментировать для тестирования случая остановки на строке 400
     'a(1) = 4: a(2) = 2: a(3) = 5: a(4) = 3: a(5) = 6: a(6) = 1
      
     'собственно генерирование всех перестановок
     j = 0
     Do
         j = j + 1
         'очередная расстановка: вывод на лист (или можно запоминать в какой-нибудь массив)
         Cells(j, 1).Resize(1, n) = a
     Loop Until NarayanaNextPerm(n, obs) = 0
      
End Sub

Function NarayanaNextPerm(n As Integer, Optional obs As Integer = 0) As Integer

     Dim i As Integer, k As Integer, t As Integer, tmp As Integer
      
     'Шаг 1
     k = n - 2 + obs
     Do While k >= 0 + obs
         If a(k) < a(k + 1) Then Exit Do
         k = k - 1
     Loop
      
     If k = -1 + obs Then
         NarayanaNextPerm = 0 'сигнал об окончании внешнего цикла генерирования
         Exit Function
     End If
          
     'Шаг 2
     t = n - 1 + obs
     Do While t >= k + 1 And a(k) >= a(t)
         t = t - 1
     Loop
     tmp = a(k): a(k) = a(t): a(t) = tmp
      
     'Шаг 3
     For i = k + 1 To (n + k + obs) \ 2
         t = n + k + obs - i
         tmp = a(i): a(i) = a(t): a(t) = tmp
     Next i
     NarayanaNextPerm = i
      
End Function