macro edit for generate 5 out of 6

[excelNewbie22]

hi!

is it possible to edit this macro here

generate combinations of a string and push the others down?

hi! how can I generate all combinations (120) of string of 5 numbers separated by hyphen in a2 but only below it, and also push the next string in a3 (and a4 and a5 and etc) to cell a121 and again, generate all combinations of a121 below it and push the next strings in a122 (and a123 and etc)...

www.mrexcel.com

to generate just all combinations of 5 out of 6 (total of 6 each) with no repeats
for example 1-2-3-4-5-6

1,2,3,4,5
1,2,3,4,6
1,2,3,5,6
1,2,4,5,6
1,3,4,5,6
2,3,4,5,6

 

[excelNewbie22]

i want it / or another one, to do this:

test.xlsm
	A	B	C	D	E	F	G	H	I	J	K
1	from this
2	1	2	3	4	5	6		to this
3							1	2	3	4	5
4							1	2	3	4	6
5							1	2	3	5	6
6							1	2	4	5	6
7							1	3	4	5	6
8							2	3	4	5	6
9	7	8	9	10	11	12
10							7	8	9	10	11
11							7	8	9	10	12
12							and etc
13							and etc
14							and etc
15							and etc
16	4	11	12	14	15	22
17							and etc
18
test

the macro is (belongs to Generating permutations of multiple cells in a database based on input)

Option Explicit
'Source: https://stackoverflow.com/questions/47391728/generating-permutations-of-multiple-cells-in-a-database-based-on-input
Sub ListPermutations()

    Dim i As Long, j As Long, k As Long, n As Long
    Dim items As Variant
    Dim strOriginalList() As String
    Dim wsSrc As Worksheet
    Dim rngCell As Range
 
    Set wsSrc = ThisWorkbook.Sheets("test") 'Sheet name containing the data. Change if required.
    j = wsSrc.Cells(Rows.Count, "A").End(xlUp).Row 'Assumes original list is in Col. A. Change if required.
 
    For Each rngCell In wsSrc.Range("A2:A" & j)
        ReDim Preserve strOriginalList(k)
        strOriginalList(k) = rngCell.Value
        k = k + 1
    Next rngCell
 
    wsSrc.Range("A2:A" & j).ClearContents
    j = 2
 
    For k = LBound(strOriginalList) To UBound(strOriginalList)
        n = UBound(Split(strOriginalList(k), "-")) + 1
        ReDim items(1 To n)
        For i = 1 To n
            items(i) = Split(strOriginalList(k), "-")(i - 1)
        Next i
        items = Permutations(items, UBound(Split(strOriginalList(k), "-")) + 1)
        For i = 1 To UBound(items)
            Cells(j, 2).Value = items(i)
            j = j + 1
        Next i
    Next k
 
End Sub
Function Permutations(items As Variant, r As Long, Optional delim As String = "-") As Variant
    'items is a 1-based array of items
    'returns all nPr permutations of items
    'returns a 1-based variant array
    'where each item is a delimited string
    'represented the permutation
    'r is assumed to be < n

    Dim n As Long, i As Long, j As Long, k As Long
    Dim rest As Variant, perms As Variant
    Dim item As Variant

    n = UBound(items) 'number of items
    ReDim perms(1 To Application.WorksheetFunction.Permut(n, r))

    If r = 1 Then
        'basis case
        For i = 1 To n
            perms(i) = items(i)
        Next i
    Else
        k = 1
        For i = 1 To n
            item = items(i)
            ReDim rest(1 To n - 1)
            For j = 1 To n - 1
                If j < i Then
                    rest(j) = items(j)
                Else
                    rest(j) = items(j + 1)
                End If
            Next j
            rest = Permutations(rest, r - 1)
            For j = 1 To UBound(rest)
                perms(k) = item & delim & rest(j)
                k = k + 1
            Next j
        Next i
    End If
 
    Permutations = perms
 
End Function

 

[Trebor76]

See how this goes:

Option Explicit
'Source: https://stackoverflow.com/questions/47391728/generating-permutations-of-multiple-cells-in-a-database-based-on-input
Sub ListPermutations()

    Dim i As Long, j As Long, k As Long, n As Long
    Dim items As Variant
    Dim strOriginalList() As String
    Dim wsSrc As Worksheet
    Dim rngCell As Range
 
    Set wsSrc = ThisWorkbook.Sheets("test") 'Sheet name containing the data. Change if required.
    j = wsSrc.Cells(Rows.Count, "A").End(xlUp).Row 'Assumes original list is in Col. A. Change if required.
 
    For Each rngCell In wsSrc.Range("A2:A" & j)
        ReDim Preserve strOriginalList(k)
        strOriginalList(k) = rngCell.Value & "-" & rngCell.Offset(0, 1).Value & "-" & rngCell.Offset(0, 2).Value & "-" & rngCell.Offset(0, 3).Value & "-" & rngCell.Offset(0, 4).Value & "-" & rngCell.Offset(0, 5).Value
        k = k + 1
    Next rngCell
 
    wsSrc.Range("A2:F" & j).ClearContents
    j = 2
 
    For k = LBound(strOriginalList) To UBound(strOriginalList)
        n = UBound(Split(strOriginalList(k), "-")) + 1
        ReDim items(1 To n)
        For i = 1 To n
            items(i) = Split(strOriginalList(k), "-")(i - 1)
        Next i
        items = Permutations(items, UBound(Split(strOriginalList(k), "-")) + 1)
        wsSrc.Range("A" & j).Value = Split(strOriginalList(k), "-")(0): wsSrc.Range("B" & j).Value = Split(strOriginalList(k), "-")(1): wsSrc.Range("C" & j).Value = Split(strOriginalList(k), "-")(2): wsSrc.Range("D" & j).Value = Split(strOriginalList(k), "-")(3): wsSrc.Range("E" & j).Value = Split(strOriginalList(k), "-")(4): wsSrc.Range("F" & j).Value = Split(strOriginalList(k), "-")(5)
        j = j + 1
        For i = 1 To UBound(items)
            wsSrc.Range("G" & j).Value = Split(items(i), "-")(0): wsSrc.Range("H" & j).Value = Split(items(i), "-")(1): wsSrc.Range("I" & j).Value = Split(items(i), "-")(2): wsSrc.Range("J" & j).Value = Split(items(i), "-")(3): wsSrc.Range("K" & j).Value = Split(items(i), "-")(4): wsSrc.Range("L" & j).Value = Split(items(i), "-")(5)
            j = j + 1
        Next i
    Next k
 
End Sub
Function Permutations(items As Variant, r As Long, Optional delim As String = "-") As Variant
    'items is a 1-based array of items
    'returns all nPr permutations of items
    'returns a 1-based variant array
    'where each item is a delimited string
    'represented the permutation
    'r is assumed to be < n

    Dim n As Long, i As Long, j As Long, k As Long
    Dim rest As Variant, perms As Variant
    Dim item As Variant

    n = UBound(items) 'number of items
    ReDim perms(1 To Application.WorksheetFunction.Permut(n, r))

    If r = 1 Then
        'basis case
        For i = 1 To n
            perms(i) = items(i)
        Next i
    Else
        k = 1
        For i = 1 To n
            item = items(i)
            ReDim rest(1 To n - 1)
            For j = 1 To n - 1
                If j < i Then
                    rest(j) = items(j)
                Else
                    rest(j) = items(j + 1)
                End If
            Next j
            rest = Permutations(rest, r - 1)
            For j = 1 To UBound(rest)
                perms(k) = item & delim & rest(j)
                k = k + 1
            Next j
        Next i
    End If
 
    Permutations = perms
 
End Function

Regards,

Robert

 

[excelNewbie22]

Trebor,
first, sorry for the pm, didn't know

second,
the macro returns 6 out 6 combinations
and i need 5 out 6
also, it returns repeats,
1 2 3 4 5 6
1 2 3 4 6 5
i only need it with order, like this

1,2,3,4,5
1,2,3,4,6
1,2,3,5,6
1,2,4,5,6
1,3,4,5,6
2,3,4,5,6

 

[johnnyL]

See if this works for you. It uses a function I found posted by StephenCrump to generate an array of values. Then I added code to replace those values for each set of numbers you chose.

Sub excelNewbie22()
'
    Dim InputNumbersRow             As Long
    Dim LastRow                     As Long, StartRow                       As Long
    Dim SourceArray()               As Long, OutputArray(1 To 6, 1 To 5)    As Long
    Dim OutputRow                   As Long
    Dim SourceArrayColumn           As Long, SourceArrayRow                 As Long
    Dim OutputColumn                As String
    Dim InputNumbersArray           As Variant
'
    StartRow = 2                                                                        ' <--- Set this to the starting row of numbers to use
    OutputColumn = "G"                                                                  ' <--- Set this to the Column letter to display results to
    LastRow = Range("A" & Rows.Count).End(xlUp).Row                                     ' Get last row # of numbers to use
    SourceArray = GetCombinations(6, 5)                                                 ' Load SourceArray with all non repeating 5 out of 6 combinations
'
    For InputNumbersRow = StartRow To LastRow Step 7                                    '
        OutputRow = InputNumbersRow + 1                                                 '   Set the OutputRow
'
        InputNumbersArray = Range("A" & InputNumbersRow).Resize(1, 6)                   '   Save numbers to use to InputNumbersArray
'
        For SourceArrayRow = 1 To 6                                                     '   Loop through rows of the SourceArray
            For SourceArrayColumn = 1 To 5                                              '       Loop through columns of the SourceArray
                If SourceArray(SourceArrayRow, SourceArrayColumn) = 1 Then
                    OutputArray(SourceArrayRow, SourceArrayColumn) = InputNumbersArray(1, 1)    '           Perform replacement array values ...
                ElseIf SourceArray(SourceArrayRow, SourceArrayColumn) = 2 Then
                    OutputArray(SourceArrayRow, SourceArrayColumn) = InputNumbersArray(1, 2)
                ElseIf SourceArray(SourceArrayRow, SourceArrayColumn) = 3 Then
                    OutputArray(SourceArrayRow, SourceArrayColumn) = InputNumbersArray(1, 3)
                ElseIf SourceArray(SourceArrayRow, SourceArrayColumn) = 4 Then
                    OutputArray(SourceArrayRow, SourceArrayColumn) = InputNumbersArray(1, 4)
                ElseIf SourceArray(SourceArrayRow, SourceArrayColumn) = 5 Then
                    OutputArray(SourceArrayRow, SourceArrayColumn) = InputNumbersArray(1, 5)
                ElseIf SourceArray(SourceArrayRow, SourceArrayColumn) = 6 Then
                    OutputArray(SourceArrayRow, SourceArrayColumn) = InputNumbersArray(1, 6)
                End If
            Next                                                                        '       Loop back
        Next                                                                            '   Loop back
'
        Range(OutputColumn & OutputRow).Resize(UBound(OutputArray), 5).Value = OutputArray  '   Display results to sheet
    Next                                                                                ' Loop back
End Sub


Function GetCombinations(lNumber As Long, lNoChosen As Long) As Long()

    Dim lOutput() As Long, lCombinations As Long
    Dim i As Long, j As Long, k As Long
 
    lCombinations = WorksheetFunction.Combin(lNumber, lNoChosen)
    ReDim lOutput(1 To lCombinations, 1 To lNoChosen)
 
    For i = 1 To lNoChosen
        lOutput(1, i) = i
    Next i
 
    For i = 2 To lCombinations
        For j = 1 To lNoChosen
            lOutput(i, j) = lOutput(i - 1, j)
        Next j
        For j = lNoChosen To 1 Step -1
            lOutput(i, j) = lOutput(i, j) + 1
            If lOutput(i, j) <= lNumber - (lNoChosen - j) Then Exit For
        Next j
        For k = j + 1 To lNoChosen
            lOutput(i, k) = lOutput(i, k - 1) + 1
        Next k
    Next i
 
    GetCombinations = lOutput
End Function

Book1
	A	B	C	D	E	F	G	H	I	J	K	L
1
2	1	2	3	4	5	6
3							1	2	3	4	5
4							1	2	3	4	6
5							1	2	3	5	6
6							1	2	4	5	6
7							1	3	4	5	6
8							2	3	4	5	6
9	7	8	9	10	11	12
10							7	8	9	10	11
11							7	8	9	10	12
12							7	8	9	11	12
13							7	8	10	11	12
14							7	9	10	11	12
15							8	9	10	11	12
16	4	11	12	14	15	22
17							4	11	12	14	15
18							4	11	12	14	22
19							4	11	12	15	22
20							4	11	14	15	22
21							4	12	14	15	22
22							11	12	14	15	22
23
Sheet1

 

[excelNewbie22]

great johnny, thanks
but it's only generate first row (a2:f2)

test.xlsm
	A	B	C	D	E	F	G	H	I	J	K
2	1	2	3	4	5	6
3	7	8	9	10	11	12	1	2	3	4	5
4	4	11	12	14	15	22	1	2	3	4	6
5							1	2	3	5	6
6							1	2	4	5	6
7							1	3	4	5	6
8							2	3	4	5	6
test

can it push the next row a3:f3 down and then generate it too and so on? like in the above macro
or even better, just generates all rows at once starting in col g ?

 

[johnnyL]

You keep changing the display.

What does your sheet look like prior to any code being run?

 

[excelNewbie22]

sorry,
didn't realize...
in post # 2 it was supposed to be how i want it to looks like,
" prior to any code " - post # 5

 

[johnnyL]

In other words your numbers to use start out in A2,A3,A4, etc?

 

[excelNewbie22]

yes