Find Combinations, Delimit, and Paste into new Tab

Option Explicit
Sub TransPaste()
    Dim n      As Long                                ' number of words
    Dim m      As Long                                ' number chosen
    Dim mMin   As Long
    Dim mMax   As Long


    Dim rOut   As Range
    Dim i      As Long                                ' scratch index
    Dim aiC()  As Long                                ' word combinations
    Dim aiP()  As Long                                ' permutations of combinations
    Dim asInp() As String                             ' input words
    Dim asCmb() As String                             ' current combination
    Dim asOut() As String                             ' permutations of asCmb
    Dim iRow   As Long                                ' output row


     Range("A4").CurrentRegion.ClearContents   'Rows("4:20").ClearContents
    For i = 1 To [B1]
        Cells(4, i) = "Month " & i


    Next i


    n = Range("IV2").End(xlToLeft).Column
    ReDim asInp(0 To n - 1)
    For i = 0 To n - 1
        asInp(i) = Cells(2, i + 1).Value
    Next i


    Set rOut = Range("A4").Resize(1, 2).Offset(1)
    'asInp = Split(WorksheetFunction.Trim(rOut(0, 2).Text), " ")


    '   rOut.Resize(Rows.Count - rOut.Row + 1).ClearContents
    '   Application.ScreenUpdating = False


    m = Range("B1").Value
    ReDim aiC(1 To m)
    ReDim aiP(1 To m)
    ReDim asCom(0 To m - 1)
    ReDim asOut(0 To m - 1)


    aiC(1) = -1
    Do While bNextCombo(aiC, n)


        For i = 1 To m
            asCom(i - 1) = asInp(aiC(i))
        Next i




        aiP(1) = -1
        Do While bNextPermut(aiP)
            For i = 1 To m
                asOut(i - 1) = asCom(aiP(i))
            Next i
            iRow = iRow + 1
            rOut.Rows(iRow).Resize(, m) = asOut
        Loop
    Loop




    Application.ScreenUpdating = True
    ActiveSheet.UsedRange
End Sub
Function bNextPermut(aiP() As Long) As Boolean
    ' VBA only


    ' Returns the next permutation in lexical order in aiP
    ' If aiP(1) < 0, returns the first permutation and True
    ' If aiP is the last permutation, returns aiP(1)= -1 and False


    ' Adapted from Applied Combinatorics/Tucker p. 224


    ' The last (0th) permutation is  {  0,   1, ..., n-2, n-1}
    ' The last (n!-1) permutation is {n-1, n-1, ...,   1,   0}


    ' shg 2009-12


    Dim aiTmp() As Long
    Dim n      As Long
    Dim i      As Long
    Dim h      As Long
    Dim bWrap  As Boolean


    n = UBound(aiP)


    If aiP(1) < 0 Then
        ' initialize to first permutation
        For i = 1 To n
            aiP(i) = i - 1
        Next i
        bNextPermut = True


    Else
        aiTmp = aiP


        For i = n - 1 To 1 Step -1
            If aiP(i) < aiP(i + 1) Then Exit For
        Next i


        If i Then
            bNextPermut = True


            For h = n To i + 1 Step -1
                If aiP(i) < aiP(h) Then Exit For
            Next h


            aiP(i) = aiP(h)
            aiP(h) = aiTmp(i)
            aiTmp(h) = aiP(h)


            For h = i + 1 To n
                aiP(h) = aiTmp(n + i + 1 - h)
            Next h


        Else
            aiP(1) = -1


        End If
    End If
End Function
Public Function bNextCombo(ByRef aiC() As Long, _
                           ByVal n As Long) As Boolean
    ' Sets aiC to the next combination of n choose m in lexical order
    ' Returns True unless the combination is the last, in which case
    ' it leaves aiC unmodified.


    ' Initializes an array with an initial value < 0 to the first combo:
    '                   {m-1,  m-2, ...,     1,   0}
    ' The last combo is {n-1,  n-2, ..., n-m+1, n-m}


    ' shg 2009-12
    '     2011-07 (modified to require aiC(0) < 0 to initialize)


    ' VBA only


    Dim m      As Long
    Dim i      As Long


    m = UBound(aiC)
    If n < m Then Exit Function


    If aiC(1) < 0 Then                                ' set initial combo
        i = 1
        aiC(1) = m - 2


    Else


        ' find rightmost incrementable index
        For i = m To 2 Step -1
            If aiC(i) < aiC(i - 1) - 1 Then Exit For
        Next i
    End If


    If i <> 1 Or aiC(1) < n - 1 Then
        ' increment that index, and set 'righter' indices descending to 0
        aiC(i) = aiC(i) + 1
        For i = i + 1 To m
            aiC(i) = m - i
        Next


        bNextCombo = True
    End If
End Function

Option Explicit
Sub TransPaste()
    Dim n      As Long
    Dim e      As Long
    Dim m      As Long
    Dim rOut   As Range
    Dim i      As Long
    Dim ii     As Long
    Dim aiC()  As Long
    Dim aiP()  As Long
    Dim asInp() As String
    Dim asCmb() As String
    Dim asOut() As String
    Dim iRow   As Long


    Range("A4").CurrentRegion.ClearContents
    Application.ScreenUpdating = False
    For i = 1 To [B1]
        Cells(4, i) = "Month " & i


    Next i


    n = Range("IV2").End(xlToLeft).Column
    e = n
    n = n * n
    ReDim asInp(0 To n - 1)


    For i = 0 To n - 1
        ii = ii + 1
        If ii > e Then ii = 1
        asInp(i) = Cells(2, ii).Value
    Next i


    Set rOut = Range("A4").Resize(1, 2).Offset(1)


    m = Range("B1").Value
    ReDim aiC(1 To m)
    ReDim aiP(1 To m)
    ReDim asCom(0 To m - 1)
    ReDim asOut(0 To m - 1)


    aiC(1) = -1
    With CreateObject("Scripting.Dictionary")
        .CompareMode = vbTextCompare
        Do While bNextCombo(aiC, n)


            For i = 1 To m
                asCom(i - 1) = asInp(aiC(i))
            Next i


            aiP(1) = -1


            Do While bNextPermut(aiP)
                For i = 1 To m
                    asOut(i - 1) = asCom(aiP(i))
                Next i


                If Not .exists(Join(asOut, " ")) Then


                    .Add Join(asOut, " "), Join(asOut, " ")


                    iRow = iRow + 1
                    rOut.Rows(iRow).Resize(, m) = asOut
                End If


            Loop
        Loop
    End With


    Application.ScreenUpdating = True


End Sub
Function bNextPermut(aiP() As Long) As Boolean
    ' VBA only


    ' Returns the next permutation in lexical order in aiP
    ' If aiP(1) < 0, returns the first permutation and True
    ' If aiP is the last permutation, returns aiP(1)= -1 and False


    ' Adapted from Applied Combinatorics/Tucker p. 224


    ' The last (0th) permutation is  {  0,   1, ..., n-2, n-1}
    ' The last (n!-1) permutation is {n-1, n-1, ...,   1,   0}


    ' shg 2009-12


    Dim aiTmp() As Long
    Dim n      As Long
    Dim i      As Long
    Dim h      As Long
    Dim bWrap  As Boolean


    n = UBound(aiP)


    If aiP(1) < 0 Then
 
        For i = 1 To n
            aiP(i) = i - 1
        Next i
        bNextPermut = True


    Else
        aiTmp = aiP


        For i = n - 1 To 1 Step -1
            If aiP(i) < aiP(i + 1) Then Exit For
        Next i


        If i Then
            bNextPermut = True


            For h = n To i + 1 Step -1
                If aiP(i) < aiP(h) Then Exit For
            Next h


            aiP(i) = aiP(h)
            aiP(h) = aiTmp(i)
            aiTmp(h) = aiP(h)


            For h = i + 1 To n
                aiP(h) = aiTmp(n + i + 1 - h)
            Next h


        Else
            aiP(1) = -1


        End If
    End If
End Function
Public Function bNextCombo(ByRef aiC() As Long, _
                           ByVal n As Long) As Boolean




    Dim m      As Long
    Dim i      As Long


    m = UBound(aiC)
    If n < m Then Exit Function


    If aiC(1) < 0 Then
        i = 1
        aiC(1) = m - 2


    Else


        For i = m To 2 Step -1
            If aiC(i) < aiC(i - 1) - 1 Then Exit For
        Next i
    End If


    If i <> 1 Or aiC(1) < n - 1 Then


        aiC(i) = aiC(i) + 1
        For i = i + 1 To m
            aiC(i) = m - i
        Next


        bNextCombo = True
    End If
End Function