Распечатать перестановки с условием

Private prmArr() As Long
 
Sub main()
    Dim n As Long, i As Long, k As Long
    n = 6
    ReDim prmArr(1 To n) As Long, a(1 To n) As Long
    For i = 1 To n
        prmArr(i) = i + i Mod 2 - 1
    Next i
 
    Do
        k = k + 1
        ReDim b(1 To n) As Long
        Debug.Print k,
        For i = 1 To n
            a(i) = prmArr(i) + b(prmArr(i))
            b(prmArr(i)) = b(prmArr(i)) + 1
            Debug.Print a(i);
        Next i
        Debug.Print
    Loop While MyNarayanaNextPerm(n)
 
End Sub
 
Function MyNarayanaNextPerm(n As Long) As Long
    Dim i As Long, k As Long, t As Long, tmp As Long
    
    For k = n - 1 To 1 Step -1
        If prmArr(k) < prmArr(k + 1) Then Exit For
    Next k
        
    If k Then
        t = n
        While t > k And prmArr(k) >= prmArr(t)
            t = t - 1
        Wend
        tmp = prmArr(k): prmArr(k) = prmArr(t): prmArr(t) = tmp
        t = n
        For i = k + 1 To (n + k) \ 2
            tmp = prmArr(i): prmArr(i) = prmArr(t): prmArr(t) = tmp
            t = t - 1
        Next i
        MyNarayanaNextPerm = i
    End If
End Function