Option Base 1
Option Explicit
Option Private Module
'==================================================================================================
Function PRDX_Combine_Factorial(ByVal n&) As Double      ' n[1:170]
Static st&, f&, a() As Double

If st = 0 Then
    st = 1: ReDim a(170)

    For f = 1 To UBound(a)
        a(f) = WorksheetFunction.Fact(f)
    Next f
End If

PRDX_Combine_Factorial = a(n)
End Function
'--------------------------------------------------------------------------------------------------
Private Sub Test_PRDX_Combine_Factorial()
Dim t!, n&, f#

t = Timer
    For n = 1 To 10000000                   ' 10 mln
'        f = WorksheetFunction.Fact(170)    ' 19.14
'        f = PRDX_Combine_Factorial(170)    ' 00.90
    Next n
Debug.Print Format$(Timer - t, "0.00"), f

End Sub
'==================================================================================================
'==================================================================================================
Function PRDX_Combine_PermutationsAll_Count(ByVal n&) As Double  ' n[1:170]
Dim f#, p#, c&

If n = 1 Then PRDX_Combine_PermutationsAll_Count = 1: Exit Function
If n = 2 Then PRDX_Combine_PermutationsAll_Count = 4: Exit Function
f = PRDX_Combine_Factorial(n)

For c = 1 To n - 2
    p = p + (f / PRDX_Combine_Factorial(n - c))
Next c

PRDX_Combine_PermutationsAll_Count = p + (2 * f)
End Function
'--------------------------------------------------------------------------------------------------
Private Sub Test_PermutationsAll_Count()
Dim p#, t!, n&

t = Timer
    For n = 1 To 100000                             ' 100k
        p = PRDX_Combine_PermutationsAll_Count(170) ' 1.8
    Next n
Debug.Print Format$(Timer - t, "0.0"), p

End Sub
'--------------------------------------------------------------------------------------------------
Function PRDX_Combine_PermutationsAll_Count_Static(ByVal n&) As Double  ' n[1:170]
Static st&, c&, a() As Double

If st = 0 Then
    st = 1: ReDim a(170)

    For c = 1 To UBound(a)
        a(c) = PRDX_Combine_PermutationsAll_Count(c)
    Next c
End If

PRDX_Combine_PermutationsAll_Count_Static = a(n)
End Function
'==================================================================================================
'==================================================================================================
'==================================================================================================
' https://www.planetaexcel.ru/forum/index.php?PAGE_NAME=message&FID=1&TID=151642&TITLE_SEO=151642-kombinatorika.-metod-perestanovok.-poluchit-vse-perestanovki-elementov-odnomernogo-massiva
Private Function NextPerm(a() As Long, n&) As Boolean  'Next Permutation by lexicographical order
Dim i&, k&, t&, tmp&

For k = n - 1 To 1 Step -1
    If a(k) < a(k + 1) Then Exit For
Next k

If k Then
    For i = n To k + 1 Step -1
        If a(k) < a(i) Then tmp = a(k): a(k) = a(i): a(i) = tmp: Exit For
    Next i
    NextPerm = True
End If

t = n

For i = k + 1 To (n + k) \ 2
    tmp = a(i): a(i) = a(t): a(t) = tmp: t = t - 1
Next i
End Function
'--------------------------------------------------------------------------------------------------
Function PRDX_Combine_Permutations_GetArr1D(aElem() As String, aJoin_Accum() As String, Optional nJoinPrev&, Optional ByVal sep$ = ", ") As Boolean
Dim aTmp$(), aInd&()
Dim i&, nF&

If LBound(aElem) <> 1 Then Stop: End
If UBound(aElem) < 2 Then Stop: End

If UBound(aElem) = 2 Then
    If nJoinPrev = 0 Then ReDim aJoin_Accum(2)
    nJoinPrev = nJoinPrev + 1: aJoin_Accum(nJoinPrev) = Join(aElem, sep)
    nJoinPrev = nJoinPrev + 1: aJoin_Accum(nJoinPrev) = aElem(2) & (sep & aElem(1))
    GoTo fin
End If

If UBound(aElem) > 10 Then Stop: End ' 11 is ~49 sec

nF = WorksheetFunction.Fact(UBound(aElem))
If nJoinPrev = 0 Then ReDim aJoin_Accum(nF)
ReDim aInd(nF): ReDim aTmp(UBound(aElem))

For i = 1 To UBound(aElem)
    aInd(i) = i
Next i

Do
    For i = 1 To UBound(aElem)
        aTmp(i) = aElem(aInd(i))
    Next i
    nJoinPrev = nJoinPrev + 1: aJoin_Accum(nJoinPrev) = Join(aTmp, sep)
Loop While NextPerm(aInd(), UBound(aElem))

fin: PRDX_Combine_Permutations_GetArr1D = True
End Function
'==================================================================================================
'==================================================================================================
Sub PRDX_Combine_GetBin_Values(a() As LongLong, ByVal nVals&) ' nVals[1:19]
Dim m^, p&, n&, nA&

ReDim a((2 ^ nVals) - 1)

a(1) = 1: nA = 1

For p = 1 To nVals - 1
    m = 10 ^ p
    nA = nA + 1: a(nA) = m

    For n = 1 To nA - 1
        nA = nA + 1: a(nA) = m + a(n)
    Next n
Next p
End Sub
'--------------------------------------------------------------------------------------------------
Private Sub Test_PRDX_Combine_GetBin_Values()
Dim a^(), t!, n&

t = Timer
    PRDX_Combine_GetBin_Values a, 19
Debug.Print Format$(Timer - t, "0.00"), UBound(a) ' 0.01

For n = 1 To 10
    Debug.Print "a(" & n & ") = " & a(n)
Next n
End Sub
'==================================================================================================
Private Sub NumToArrL(ByVal nBin^, aL_ReDim() As Long)  ' nLen[1:17]
Dim m^, p^, n&, nn&, nLen&, UB&

UB = UBound(aL_ReDim)
nLen = Len(CStr(nBin))
If UB < nLen Then Stop: End
m = 10 ^ nLen

For n = nLen To 1 Step -1
    p = nBin \ m
    If p <> 0 Then nn = nn + 1: aL_ReDim(nn) = UB - n: nBin = nBin - m
    m = m / 10
Next n

If nBin <> 0 Then nn = nn + 1: aL_ReDim(nn) = UB
ReDim Preserve aL_ReDim(nn)
End Sub
'--------------------------------------------------------------------------------------------------
Private Sub Test_NumToArrL()
Dim a&(), t!, n&, v^, l

v = 1011101101#                             ' 10 sym
'v = 101
l = Len(CStr(v))

t = Timer
    For n = 1 To 1000000                    ' 1 mln
        ReDim a(15)
        NumToArrL v, a
    Next n
Debug.Print Format$(Timer - t, "0.0"), l    ' 0.8

For n = 1 To UBound(a)
    Debug.Print n, a(n)
Next n
End Sub
'==================================================================================================
Sub PRDX_Combine_GetBin_ArrArrsL(aArrs(), nVals&)       ' nVals[1:18]
Dim aB^(), aL&(), n&

PRDX_Combine_GetBin_Values aB, nVals
ReDim aArrs(UBound(aB))

For n = 1 To UBound(aB)
    ReDim aL(nVals): NumToArrL aB(n), aL: aArrs(n) = aL
Next n
End Sub
'--------------------------------------------------------------------------------------------------
Private Sub Test_PRDX_Combine_GetBin_ArrArrsL()
Dim aV(), aL&(), t!, n&, l&

t = Timer
    PRDX_Combine_GetBin_ArrArrsL aV, 10
Debug.Print Format$(Timer - t, "0.0"), UBound(aV)

For n = 1 To 10
    Debug.Print "Step: " & n, String$(50, "=")
    aL = aV(n)

    For l = 1 To UBound(aL)
        Debug.Print "aL(" & l & ") = " & aL(l)
    Next l
Next n
End Sub
'==================================================================================================
'==================================================================================================
Function PRDX_Combine_Permutations_GetArr1D_AllVariants(aElem() As String, aJoin() As String, Optional ByVal sep$ = ", ") As Boolean
Dim aV(), aStr$(), aL&(), n&, l&, j&, UB&

If LBound(aElem) <> 1 Then Stop: End
If UBound(aElem) < 2 Then Stop: End

If UBound(aElem) = 2 Then
    ReDim aJoin(4)
    aJoin(1) = aElem(1)
    aJoin(2) = Join(aElem, sep)
    aJoin(3) = aElem(2)
    aJoin(4) = aElem(2) & (sep & aElem(1))
    GoTo fin
End If

ReDim aJoin(PRDX_Combine_PermutationsAll_Count(UBound(aElem)))
PRDX_Combine_GetBin_ArrArrsL aV, UBound(aElem)

For n = 1 To UBound(aV)
    aL = aV(n): UB = UBound(aL)

    If UB = 1 Then
        j = j + 1: aJoin(j) = aElem(aL(1))
    Else
        ReDim aStr(UB)

        For l = 1 To UB
            aStr(l) = aElem(aL(l))
        Next l

        If Not PRDX_Combine_Permutations_GetArr1D(aStr, aJoin, j, sep) Then Exit Function
    End If
Next n

fin: PRDX_Combine_Permutations_GetArr1D_AllVariants = True
End Function
'--------------------------------------------------------------------------------------------------
Private Sub Test_PRDX_Combine_Permutations_GetArr1D_AllVariants()
Dim a$(), b$()

ReDim a(4)
a(1) = "маша"
a(2) = "петя"
a(3) = "даша"
a(4) = "вася"

If Not PRDX_Combine_Permutations_GetArr1D_AllVariants(a, b) Then Exit Sub
Debug.Print Join(b, vbLf)
End Sub