Function Fac(ByVal n As Long) As Double
   If n = 0 Then Fac = 1 Else Fac = n * Fac(n - 1)
End Function

Option Explicit
Private iArr& 'текущее положение в массиве с перестановками
Public prst&() 'массив с перестановками

Sub www()
     Dim a&(), i&, m&, kp&

     Range("A1").CurrentRegion.Clear
     m = 6 'кол-во чисел
     kp = Application.Fact(m) 'кол-во перестановок

     ReDim a&(1 To m), prst&(1 To kp, 1 To m)
     iArr = 0
     For i = 1 To m: a(i) = i: Next i
     Call Perestanovki(a, m, m) 'генерируем перестановки

     Range("A1").Resize(kp, m) = prst
End Sub

Private Sub Perestanovki(ByVal arr, m&, n&) 'генерация перестановок
     Dim i&, tmp&
     If m = 1 Then
         iArr = iArr + 1
         For i = 1 To n
             prst(iArr, i) = arr(i)
         Next i
     Else
         For i = m To 1 Step -1
             tmp = arr(i): arr(i) = arr(m): arr(m) = tmp
             Call Perestanovki(arr, m - 1, n)
         Next i
     End If
End Sub

Option Explicit

Private theSortedList() As Integer
Private theBlncTree() As Integer

Public Sub AdjustTreeDepth(ByRef binTree() As Integer)
Dim n As Integer
'Выравнивание двоичного дерева по глубине
'theBlncTree(0, 1) - корень

    theBlncTree = binTree
      ReDim theSortedList(1 To UBound(binTree))
      n = FillSortedList(theBlncTree(0, 1), 0)
      theBlncTree(0, 1) = HalfByHalf(1, n)
    binTree = theBlncTree
End Sub

Private Function FillSortedList(k As Integer, last As Integer) As Integer
'Рекурсивное заполнение сортированного списка theSortedList из двоичного дерева theBlncTree
'k - индекс текущего узла двоичного дерева
'last - кол-во заполненных позиций списка

      If theBlncTree(k, 1) > 0 Then last = FillSortedList(theBlncTree(k, 1), last)
      last = last + 1
      theSortedList(last) = k
      If theBlncTree(k, 2) > 0 Then last = FillSortedList(theBlncTree(k, 2), last)
      FillSortedList = last
End Function

Private Function HalfByHalf(a As Integer, b As Integer) As Integer
'Рекурсивное заполнение дерева theBlncTree делением списка пополам theSortedList
'a, b - границы текущего фрагмента списка
Dim c As Integer

      c = Int((a + b) / 2)
      HalfByHalf = theSortedList(c)
      If c > a Then
          theBlncTree(HalfByHalf, 1) = HalfByHalf(a, c - 1)
      Else
          theBlncTree(HalfByHalf, 1) = 0
      End If
      If c < b Then
          theBlncTree(HalfByHalf, 2) = HalfByHalf(c + 1, b)
      Else
          theBlncTree(HalfByHalf, 2) = 0
      End If
        
End Function

Call Recursion(elem, col)
Exit Sub    ' <--