Grouped Unique Combinations Generator

mikiel111

New Member
Joined
Mar 17, 2020
Messages
38
Office Version
  1. 365
Hi there,

I`m looking to get a unique combinations generator macro adjusted, not sure if it is possible. The original macro request was already beyond me so there`s no chance in hell I`ll manage this.
The Macro created in the linked thread (i attached the excel file w/ macro) delivers all unique combinations of a list`s elements.
So from the below list of 5 elements
1630084870088.png


It will deliver combinations which are unique. By unique I mean if it delivers combination 1 & 5 it will NOT deliver 5 & 1.
The combinations can consist of between 2 & 6 numbers (e.g. it delivers 111112 [but NOT 111121, 11211, 12111 & 21111]).

1630085004292.png


Would it be possible to give the macro functionality to do combinations of each group (picture 1) & then output combinations between those groups (picture 2)? This will save me from going through like 1000s of records to manually remove ones I cannot use (like 111112, 111333). If it is not possible is there some simpler way i can go about getting a similar outcome?

Picture 1
1630087015718.png



Picture 2


1630090897917.png



This is the code which gives me the unique combinations & here is the file Box (credit goes to user StephenCrump for it)

VBA Code:
' PGC Set 2007
' Calculates and writes the Combinations / Permutations with/without repetition
' vElements - Array with the set elements (1 to n)
' p - number of elements in 1 combination/permutation
' bComb - True: Combinations, False: Permutations
' bRepet - True: with repetition, False: without repetition
' vResult - Array to hold 1 permutation/combination (1 to p)
' lRow - row number. the next combination/permutation is written in lRow+1
' vResultAll - Array to hold all the permutations/combinations (1 to Total, 1 to p)
' iElement - order of the element to process in case of combination
' iIndex - position of the next element in the combination/permutation
' Sub CombPerm() deals with the input / output
' Sub CombPermNP() generates the combinations / permutations
Sub DoIt()

    Dim vElements As Variant, vResult As Variant, vResultAll As Variant
    Dim lrow As Long, lTotal As Long, p As Long, pMax As Long, i As Long, NoRows As Long
    Dim bComb As Boolean, bRepet As Boolean
    Dim rng As Range
  
    p = 5       'Number of elements in combination
    pMax = 5    'Careful! The code clears this many columns, i.e. C,E,G,I,K,M for pMax=6
    bComb = True
    bRepet = True
    With Worksheets("Chosen List")
        Set rng = .Range("A" & .Range("StartRow").Row & ":A" & .Range("A" & Rows.Count).End(xlUp).Row)
    End With
    vElements = Application.Index(Application.Transpose(rng), 1, 0)
  
    With Application
        If bComb Then
            lTotal = .Combin(UBound(vElements) + IIf(bRepet, p - 1, 0), p)
        Else
            If bRepet = False Then lTotal = .Permut(UBound(vElements), p) Else lTotal = UBound(vElements) ^ p
        End If
    End With
    ReDim vResult(1 To p)
    ReDim vResultAll(1 To lTotal, 1 To p)

    Call CombPermNP(vElements, p, True, True, vResult, lrow, vResultAll, 1, 1)
  
    With Worksheets("Daily Meal Macro").Range("StartRow")
        NoRows = .End(xlDown).Row - .Row + 1
        For i = 0 To p - 1
            With .Offset(, 2 * i)
                .Resize(NoRows).ClearContents
                .Resize(lTotal).Value = Application.Index(vResultAll, , i + 1)
            End With
        Next i
        For i = p To pMax - 1
            .Offset(, 2 * i).Resize(NoRows).ClearContents
        Next i
    End With
  
End Sub
Sub CombPermNP(ByVal vElements As Variant, ByVal p As Integer, ByVal bComb As Boolean, ByVal bRepet As Boolean, _
                             ByVal vResult As Variant, ByRef lrow As Long, ByRef vResultAll As Variant, ByVal iElement As Integer, ByVal iIndex As Integer)
Dim i As Integer, j As Integer, bSkip As Boolean
 
For i = IIf(bComb, iElement, 1) To UBound(vElements)
    bSkip = False
    ' in case of permutation without repetition makes sure the element is not yet used
    If (Not bComb) And Not bRepet Then
        For j = 1 To p
            If vElements(i) = vResult(j) And Not IsEmpty(vResult(j)) Then
                bSkip = True
                Exit For
            End If
        Next
    End If
 
    If Not bSkip Then
        vResult(iIndex) = vElements(i)
        If iIndex = p Then
            lrow = lrow + 1
            For j = 1 To p
                vResultAll(lrow, j) = vResult(j)
            Next j
        Else
            Call CombPermNP(vElements, p, bComb, bRepet, vResult, lrow, vResultAll, i + IIf(bComb And bRepet, 0, 1), iIndex + 1)
        End If
    End If
Next i
End Sub
 

Attachments

  • 1630084897520.png
    1630084897520.png
    14.9 KB · Views: 12

Excel Facts

Copy PDF to Excel
Select data in PDF. Paste to Microsoft Word. Copy from Word and paste to Excel.

EXCEL MAX

Well-known Member
Joined
Nov 11, 2020
Messages
508
Office Version
  1. 2016
Platform
  1. Windows
Hello Mikiell111,
here is code according to your request.
The first part of code changes script from your workbook.
Second part is creation of combinations.
Be careful with sizing, the number of possible combination can be huge. For your example is 180.
VBA Code:
Sub GroupedUniqueCombinationsGenerator()
    
    Dim vA, vA1, vA2, vA3, vA11(), vA22(), vA33(), vAFinal()
    Dim vN As Long, vN1 As Long, vN2 As Long
    Dim vB As Long, vC As Long, vR As Long
    
    With Worksheets("MealList")
        vA1 = .[A1:B3]
        vA2 = .[A4:B7]
        vA3 = .[A8:B9]
    End With
    vA = Array(vA1, vA2, vA3)
    ReDim Preserve vA11(1 To UBound(vA1) * (UBound(vA1) + 1) / 2)
    ReDim Preserve vA22(1 To UBound(vA2) * (UBound(vA2) + 1) / 2)
    ReDim Preserve vA33(1 To UBound(vA3) * (UBound(vA3) + 1) / 2)
'first part
    For vN = 0 To UBound(vA)
        vC = 1
        For vN1 = 1 To UBound(vA(vN)) * (UBound(vA(vN)) + 1) / 4
            For vN2 = 1 To UBound(vA(vN)) - vB
                vR = vR + 1
                Select Case vN
                    Case 0
                        vA11(vR) = vA(vN)(vN1, 1) & vA(vN)(vC, 2)
                    Case 1
                        vA22(vR) = vA(vN)(vN1, 1) & vA(vN)(vC, 2)
                    Case 2
                        vA33(vR) = vA(vN)(vN1, 1) & vA(vN)(vC, 2)
                End Select
                vC = vC + 1
            Next vN2
            vB = vB + 1
            vC = vB + 1
        Next vN1
        vB = 0
        vR = 0
    Next vN
'second part
    ReDim Preserve vAFinal(1 To UBound(vA11) _
                              * UBound(vA22) _
                              * UBound(vA33), 1 To 1)
    For vN = 1 To UBound(vA11)
        For vN1 = 1 To UBound(vA22)
            For vN2 = 1 To UBound(vA33)
                vR = vR + 1
                vAFinal(vR, 1) = vA11(vN) _
                               & vA22(vN1) _
                               & vA33(vN2)
            Next vN2
        Next vN1
    Next vN
    With Sheets("DailyMealMacro")
       .Columns(7).ClearContents
       .[G2].Resize(UBound(vAFinal)) = vAFinal
    End With
   
End Sub
 

EXCEL MAX

Well-known Member
Joined
Nov 11, 2020
Messages
508
Office Version
  1. 2016
Platform
  1. Windows
I'm glad if works as you expected and if getting good results.;)
 

mikiel111

New Member
Joined
Mar 17, 2020
Messages
38
Office Version
  1. 365

ADVERTISEMENT

I figured out how you determined which is group A, B & C. I tried to modify them slightly to see if I could get it how I need but I get a subscript out of range error

Currently it can only give me combinations of 3 items/elements (1 from each vA1/2/3). The combinations that I need to output can consist of between 3 & 6 items, not always the same. If it is helpful in my original code I determine how many elements I want in my combination by altering p. So p=6 means my combinations will be made of 6 elements from whatever amount of elements in the main list (e.g. from a list with 8 elements & p =6 this would be one of the many combinations 1,1,3,3,6,8).
(p can never be higher than 6 in my original code)

VBA Code:
p = 5       'Number of elements in combination
    pMax = 5    'Careful! The code clears this many columns, i.e. C,E,G,I,K,M for pMax=6

Also currently the macro outputs the item descriptions in 1 column, unfortunately I cannot use that. Reasoning being I pull data (using match/index) from other sheets using the ID of the items/elements.
What I would need the output to be just the IDs of the items for which we`re making combinations of & I would need them in very specific columns. Unfortunately I cannot identify where in my code it determines where the macro decides to start placing the output. They would need to start from row 7 & depending on how many elements I need a combination of the elements would be in columns C,E,G,I,K 7 M

Here`s an example with 6 elements in my combination (p = 6 in my original code)
1st combination placements = 1st element of a combination in C7, the 2nd element in E7, 3rd in G7, 4th in I7, 5th in K7 & 6th in M7.
2nd combination placements = 1st element of a combination in C8, the 2nd element in E8, 3rd in G8, 4th in I8, 5th in K8 & 6th in M8.
3rd etc.....

1630514466165.png


Here`s another example having 3 elements in the combination (p = 3 in my original code)

1630514786866.png
 

mikiel111

New Member
Joined
Mar 17, 2020
Messages
38
Office Version
  1. 365
I figured out how you determined which is group A, B & C. I tried to modify them slightly to see if I could get it how I need but I get a subscript out of range error

Currently it can only give me combinations of 3 items/elements (1 from each vA1/2/3). The combinations that I need to output can consist of between 3 & 6 items, not always the same. If it is helpful in my original code I determine how many elements I want in my combination by altering p. So p=6 means my combinations will be made of 6 elements from whatever amount of elements in the main list (e.g. from a list with 8 elements & p =6 this would be one of the many combinations 1,1,3,3,6,8).
(p can never be higher than 6 in my original code)

VBA Code:
p = 5       'Number of elements in combination
    pMax = 5    'Careful! The code clears this many columns, i.e. C,E,G,I,K,M for pMax=6


To give further clarity to this

The combinations (e.g. again let`s say a combination of 6 elements/items [what I call as p = 6 in my original code]) could consist of x elements/items from vA1, y elements/items from vA2 & z elements/items from vA3. (x+y+z= 6 obviously as number of elements in combination I chose 6).

Same story for another example combination of 4 elements/items (aka p = 4) -> x elements/items from vA1, y elements/items from vA2 & z elements/items from vA3. (x+y+z= 4)

Is this do-able?
 

EXCEL MAX

Well-known Member
Joined
Nov 11, 2020
Messages
508
Office Version
  1. 2016
Platform
  1. Windows

ADVERTISEMENT

It's hard to understand what will be the best correction, but try this and see is the output OK.
VBA Code:
Sub GroupedUniqueCombinationsGenerator2()
    
    Dim vA, vAA, vA1, vA2, vA3
    Dim vA11(), vA22(), vA33(), vA11B(), vA22B(), vA33B()
    Dim vN As Long, vN1 As Long, vN2 As Long
    Dim vB As Long, vC As Long, vR As Long
'first part - set "A, B, C" ranges
    With Worksheets("MealList")
        vA1 = .[A1:B2]
        vA2 = Empty
        vA3 = .[A4:B4]
    End With
    vA = Array(vA1, vA2, vA3)
 'second part - size the arrays
   With Application
        If Not IsEmpty(vA1) Then
            ReDim vA11(1 To .Combin(UBound(vA1) + 1, 2), 1 To 1)
            ReDim vA11B(1 To .Combin(UBound(vA1) + 1, 2), 1 To 1)
        End If
        If Not IsEmpty(vA2) Then
            ReDim vA22(1 To .Combin(UBound(vA2) + 1, 2), 1 To 1)
            ReDim vA22B(1 To .Combin(UBound(vA2) + 1, 2), 1 To 1)
         End If
        If Not IsEmpty(vA3) Then
            ReDim vA33(1 To .Combin(UBound(vA3) + 1, 2), 1 To 1)
            ReDim vA33B(1 To .Combin(UBound(vA3) + 1, 2), 1 To 1)
         End If
'third part - creating combinations for each column
        For vN = 0 To UBound(vA)
            vC = 1
            If Not IsEmpty(vA(vN)) Then
                v2U = .RoundUp(.Combin(UBound(vA(vN)) + 1, 2) / 2, 0)
                For vN1 = 1 To v2U
                    For vN2 = 1 To UBound(vA(vN)) - vB
                        vR = vR + 1
                        Select Case vN
                            Case 0
                                vA11(vR, 1) = vA(vN)(vN1, 1)
                                vA11B(vR, 1) = vA(vN)(vC, 1)
                            Case 1
                                vA22(vR, 1) = vA(vN)(vN1, 1)
                                vA22B(vR, 1) = vA(vN)(vC, 1)
                            Case 2
                                vA33(vR, 1) = vA(vN)(vN1, 1)
                                vA33B(vR, 1) = vA(vN)(vC, 1)
                        End Select
                        vC = vC + 1
                    Next vN2
                    vB = vB + 1
                    vC = vB + 1
                Next vN1
            End If
            vB = 0
            vR = 0
        Next vN
    End With
'fourth part - display on the sheet
    vAA = Array(vA11, vA22, vA33, vA11B, vA22B, vA33B)
    With Sheets("DailyMealMacro")
        .Range("C:C,E:E,G:G,I:I,K:K,M:M").ClearContents
        b = 2
        For vN = 0 To UBound(vA)
            If Not IsEmpty(vA(vN)) Then
                .Cells(7, 3 + a).Resize(UBound(vAA(vN))) = vAA(vN)
                .Cells(7, 3 + b).Resize(UBound(vAA(vN + 3))) = vAA(vN + 3)
                a = a + 4
                b = b + 4
            End If
        Next vN

    End With
    
End Sub
 

mikiel111

New Member
Joined
Mar 17, 2020
Messages
38
Office Version
  1. 365
Hmm unfortunately it`s still a bit off.
Whilst from a list of 14 items divided into 3 groups (blue/orange/gold) I am getting unique combinations for each group, each combination is still limited to 2 (see pic below)
1630757280054.png


My situation would be such that each group might require combinations of more than 2 items (e.g. 1-1-3) & the amount of items in a combination might also be different (example: 5 items in blue group but need combinations of 2, whilst 4 items in orange/brown group but need combinations of 3)..

The combinations of each individual group are also not being done against each other.

Below is just a part of the output i would require (assuming i wanted just 2 items in each group). As you can see the combinations will run into the high 1000s

1630758405155.png


Here is another example where i changed the number of combinations in some of the groups

1630758842592.png
 

StephenCrump

MrExcel MVP
Joined
Sep 18, 2013
Messages
4,346
Office Version
  1. 365
Platform
  1. Windows
@mikiel111, thanks for the PM ....

Here's one way you could do this - input highlighted yellow. If you get #SPILL! errors for bigger datasets, insert more rows/columns as required.

ABCDEFGHIJK
1ItemsGroup123
2Item 11Item 1Item 1Item 4Item 8Item 8
3Item 21Item 1Item 2Item 5Item 8Item 9
4Item 31Item 1Item 3Item 6Item 9Item 9
5Item 42Item 2Item 2Item 7
6Item 52Item 2Item 3
7Item 62Item 3Item 3
8Item 72
9Item 83
10Item 93
11
12Repeats?TRUE
13
14GroupSizesCombinsCumulativeProduct
151261272
162143
173231
18
19CombinationsItem 1Item 1Item 4Item 8Item 8
20Item 1Item 1Item 4Item 8Item 9
21Item 1Item 1Item 4Item 9Item 9
22Item 1Item 1Item 5Item 8Item 8
23Item 1Item 1Item 5Item 8Item 9
24Item 1Item 1Item 5Item 9Item 9
25Item 1Item 1Item 6Item 8Item 8
26Item 1Item 1Item 6Item 8Item 9
27Item 1Item 1Item 6Item 9Item 9
28Item 1Item 1Item 7Item 8Item 8
29Item 1Item 1Item 7Item 8Item 9
30Item 1Item 1Item 7Item 9Item 9
31Item 1Item 2Item 4Item 8Item 8
32Item 1Item 2Item 4Item 8Item 9
33Item 1Item 2Item 4Item 9Item 9
34Item 1Item 2Item 5Item 8Item 8
35Item 1Item 2Item 5Item 8Item 9
36Item 1Item 2Item 5Item 9Item 9
37Item 1Item 2Item 6Item 8Item 8
38Item 1Item 2Item 6Item 8Item 9
39Item 1Item 2Item 6Item 9Item 9
40Item 1Item 2Item 7Item 8Item 8
41Item 1Item 2Item 7Item 8Item 9
42Item 1Item 2Item 7Item 9Item 9
43Item 1Item 3Item 4Item 8Item 8
44Item 1Item 3Item 4Item 8Item 9
45Item 1Item 3Item 4Item 9Item 9
46Item 1Item 3Item 5Item 8Item 8
47Item 1Item 3Item 5Item 8Item 9
48Item 1Item 3Item 5Item 9Item 9
49Item 1Item 3Item 6Item 8Item 8
50Item 1Item 3Item 6Item 8Item 9
51Item 1Item 3Item 6Item 9Item 9
52Item 1Item 3Item 7Item 8Item 8
53Item 1Item 3Item 7Item 8Item 9
54Item 1Item 3Item 7Item 9Item 9
55Item 2Item 2Item 4Item 8Item 8
56Item 2Item 2Item 4Item 8Item 9
57Item 2Item 2Item 4Item 9Item 9
58Item 2Item 2Item 5Item 8Item 8
59Item 2Item 2Item 5Item 8Item 9
60Item 2Item 2Item 5Item 9Item 9
61Item 2Item 2Item 6Item 8Item 8
62Item 2Item 2Item 6Item 8Item 9
63Item 2Item 2Item 6Item 9Item 9
64Item 2Item 2Item 7Item 8Item 8
65Item 2Item 2Item 7Item 8Item 9
66Item 2Item 2Item 7Item 9Item 9
67Item 2Item 3Item 4Item 8Item 8
68Item 2Item 3Item 4Item 8Item 9
69Item 2Item 3Item 4Item 9Item 9
70Item 2Item 3Item 5Item 8Item 8
71Item 2Item 3Item 5Item 8Item 9
72Item 2Item 3Item 5Item 9Item 9
73Item 2Item 3Item 6Item 8Item 8
74Item 2Item 3Item 6Item 8Item 9
75Item 2Item 3Item 6Item 9Item 9
76Item 2Item 3Item 7Item 8Item 8
77Item 2Item 3Item 7Item 8Item 9
78Item 2Item 3Item 7Item 9Item 9
79Item 3Item 3Item 4Item 8Item 8
80Item 3Item 3Item 4Item 8Item 9
81Item 3Item 3Item 4Item 9Item 9
82Item 3Item 3Item 5Item 8Item 8
83Item 3Item 3Item 5Item 8Item 9
84Item 3Item 3Item 5Item 9Item 9
85Item 3Item 3Item 6Item 8Item 8
86Item 3Item 3Item 6Item 8Item 9
87Item 3Item 3Item 6Item 9Item 9
88Item 3Item 3Item 7Item 8Item 8
89Item 3Item 3Item 7Item 8Item 9
90Item 3Item 3Item 7Item 9Item 9
Sheet1
Cell Formulas
RangeFormula
D2:E7,J2:K4,G2:G5D2=DoIt(FILTER(Items,Group=D1),INDEX(Sizes,D1),TRUE,Repeats)
A15:A17A15=SEQUENCE(MAX(Group))
C15:C17C15=COMBIN(COUNTIF(Group,A15#)+Repeats*(Sizes-1),Sizes)
D15:D17D15=EXP(MMULT(--TRANSPOSE(SEQUENCE(,ROWS(C15#))<=SEQUENCE(ROWS(C15#))),LN(C15#)))/C15#
E15E15=PRODUCT(C15#)
D19:E90,J19:K90,G19:G90D19=INDEX(D2#,1+MOD(SEQUENCE($E15,,0)/ROUND(INDEX($D15#,D1),0),INDEX($C15#,D1)),SEQUENCE(,INDEX(Sizes,D1)))
Dynamic array formulas.
Named Ranges
NameRefers ToCells
Group=Sheet1!$B$2:$B$10J19, G19, D19, J2, G2, D2, C15, A15
Items=Sheet1!$A$2:$A$10J2, G2, D2
Repeats=Sheet1!$B$12J19, G19, D19, J2, G2, D2, C15
Sizes=Sheet1!$B$15:INDEX(Sheet1!$B:$B,ROW(Sheet1!$B$15)+ROWS(Sheet1!$A$15#)-1)J19, J2, G19, G2, D19, D2, C15

VBA Code:
Function DoIt(vIn As Variant, p As Long, bComb As Boolean, bRepet As Boolean) As Variant()

    Dim vResult As Variant, vResultAll As Variant, vElements() As Variant
    Dim lrow As Long, lTotal As Long, r As Long, c As Long, count As Long
       
    'Convert 2D range/array to 1D array
    On Error Resume Next
    vIn = vIn.Value2
    On Error GoTo 0
    ReDim vElements(1 To UBound(vIn) * UBound(vIn, 2))
    For c = 1 To UBound(vIn, 2)
        For r = 1 To UBound(vIn)
            count = count + 1
            vElements(count) = vIn(r, c)
        Next r
    Next c
   
    With Application
        If bComb Then
            lTotal = .Combin(UBound(vElements) + IIf(bRepet, p - 1, 0), p)
        Else
            If bRepet = False Then lTotal = .Permut(UBound(vElements), p) Else lTotal = UBound(vElements) ^ p
        End If
    End With
   
    ReDim vResult(1 To p)
    ReDim vResultAll(1 To lTotal, 1 To p)
    Call CombPermNP(vElements, p, bComb, bRepet, vResult, lrow, vResultAll, 1, 1)
    DoIt = vResultAll
   
End Function
Sub CombPermNP(ByVal vElements As Variant, ByVal p As Integer, ByVal bComb As Boolean, ByVal bRepet As Boolean, _
                             ByVal vResult As Variant, ByRef lrow As Long, ByRef vResultAll As Variant, ByVal iElement As Integer, ByVal iIndex As Integer)
    Dim i As Integer, j As Integer, bSkip As Boolean
    
    For i = IIf(bComb, iElement, 1) To UBound(vElements)
        bSkip = False
        ' in case of permutation without repetition makes sure the element is not yet used
        If (Not bComb) And Not bRepet Then
            For j = 1 To p
                If vElements(i) = vResult(j) And Not IsEmpty(vResult(j)) Then
                    bSkip = True
                    Exit For
                End If
            Next
        End If
    
        If Not bSkip Then
            vResult(iIndex) = vElements(i)
            If iIndex = p Then
                lrow = lrow + 1
                For j = 1 To p
                    vResultAll(lrow, j) = vResult(j)
                Next j
            Else
                Call CombPermNP(vElements, p, bComb, bRepet, vResult, lrow, vResultAll, i + IIf(bComb And bRepet, 0, 1), iIndex + 1)
            End If
        End If
    Next i

End Sub
This is the code which gives me the unique combinations & here is the file Box (credit goes to user StephenCrump for it)
Thanks, but as I noted here: unique combinations generator ...

credit for the starting code goes to @pgc01, from this thread: Combination, Repeats (AAB,BBC) allowed, Repeats (AAC,ACA,CAA) only considered as One
 
Last edited:

EXCEL MAX

Well-known Member
Joined
Nov 11, 2020
Messages
508
Office Version
  1. 2016
Platform
  1. Windows
After I have been deeper studying your last post, I have change your code and it seems now it's a little bit closer to your request.

VBA Code:
    Dim vA, p1 As Long, p2 As Long, p3 As Long, vN As Integer
    Dim lrow As Long

Sub DoIt()

    Dim vElements As Variant, vResult As Variant, vResultAll As Variant
    Dim lTotal As Long, p, p1 As Long, p2 As Long, p3 As Long, i As Long, NoRows As Long
    Dim bComb As Boolean, bRepet As Boolean
    Dim rng As Range, vA1, vA2, vA3, vAA, vAFinal()
    Dim vN2 As Long, vC As Integer
    
    Application.ScreenUpdating = False
    With Worksheets("MealList")
        Set vA1 = .[A1:B10]
        Set vA2 = .[A11:B20]
        Set vA3 = .[A21:B30]
        p1 = 2
        p2 = 2
        p3 = 2
        vA = Array(p1, p2, p3)
        vAA = Array(vA1.Address, vA2.Address, vA3.Address)
        vC = 1
    End With
    Worksheets("DailyMealMacro").Range("C:C,E:E,G:G,I:I,K:K,M:M").ClearContents
    For vN = 0 To UBound(vA)
        With Worksheets("MealList")
            Set rng = .Range(vAA(vN))
            vElements = Application.Index(Application.Transpose(rng), 1, 0)
        End With
        p = vA(vN) 'Number of elements in combination
        bComb = True
        bRepet = True
        With Application
            If bComb Then
                lTotal = .Combin(UBound(vElements) + IIf(bRepet, p - 1, 0), p)
            Else
                If bRepet = False Then lTotal = .Permut(UBound(vElements), p) Else lTotal = UBound(vElements) ^ p
            End If
        End With
        ReDim vResult(1 To p)
        ReDim vResultAll(1 To lTotal, 1 To p)
        ReDim vAFinal(1 To lTotal, 1 To 1)
        Call CombPermNP(vElements, p, True, True, vResult, lrow, vResultAll, 1, 1)
        With Worksheets("DailyMealMacro").Range("StartRow")
            NoRows = .End(xlDown).Row - .Row + 1
            For i = 0 To p - 1
                .Offset(, vC).Resize(NoRows).ClearContents
                For vN2 = 1 To UBound(vResultAll)
                    vAFinal(vN2, 1) = vResultAll(vN2, i + 1)
                Next
                .Cells(.Row, vC).Resize(UBound(vResultAll), 1) = vAFinal
                vC = vC + 2
                lrow = 0
            Next i
         End With
    Next vN
   
End Sub

Sub CombPermNP(ByVal vElements As Variant, ByVal p As Integer, ByVal bComb As Boolean, ByVal bRepet As Boolean, _
                             ByVal vResult As Variant, ByRef lrow As Long, ByRef vResultAll As Variant, ByVal iElement As Integer, ByVal iIndex As Integer)

    Dim i As Integer, j As Integer, bSkip As Boolean
     
    For i = IIf(bComb, iElement, 1) To UBound(vElements)
        bSkip = False
        ' in case of permutation without repetition makes sure the element is not yet used
        If (Not bComb) And Not bRepet Then
            For j = 1 To p
                If vElements(i) = vResult(j) And Not IsEmpty(vResult(j)) Then
                    bSkip = True
                    Exit For
                End If
            Next
        End If
     
        If Not bSkip Then
            vResult(iIndex) = vElements(i)
            If iIndex = p Then
                lrow = lrow + 1
                For j = 1 To p
                    vResultAll(lrow, j) = vResult(j)
                Next j
            Else
                Call CombPermNP(vElements, p, bComb, bRepet, vResult, lrow, vResultAll, i + IIf(bComb And bRepet, 0, 1), iIndex + 1)
            End If
        End If
    Next i
        
End Sub
 

Forum statistics

Threads
1,147,562
Messages
5,741,848
Members
423,691
Latest member
Fahad987

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top