Consulting

Results 1 to 12 of 12

Thread: Need VBA code to return r combinations from a group of n

  1. #1

    Need VBA code to return r combinations from a group of n

    Hi,

    I have numeric co-variates in groups of 1, 2, 3, 4, 5, 6, etc.

    Each group corresponds to a study I conducted

    I'm trying to find all possible combinations of each study's group of co-variates - for example, if study 1 has corresponding co-variates 8, 3, 7.... then I want to find 3C2... so (8, 3) would be the first 2character group; (8, 7) would be the 2nd 2character group; and so on...

    In Excel, I have my "studies" in row 1, and then the "groups of co-variates" corresponding to each study in row 2, and then I have the groups I want to combine them into (i.e., r=2, 3, 4, etc.) in the subsequent rows

    I'm wondering if there is a macro I could use for this?

    I'm attaching a sample of my data to give a better idea of exactly what I'm trying to achieve - I've manually created the combinations for "study 3".

    My data is quite large, and I'm really hoping to be able to create a UDF whereby I can just enter the function name (e.g., Combinations), select the range (i.e., the single group of co-variates corresponding to the study), and then enter the "r" I need

    Sorry if the above doesn't make sense, I'm quite new to VBA but think it may be my best option here! - feel free to ask any questions, all help is greatly appreciated as I really need to find a Macro to help me perform this function quickly!!!

    Thank you in advance

    Sample data.xlsx

  2. #2
    VBAX Wizard
    Joined
    Apr 2007
    Posts
    6,516
    Location
    Using a UDF was too finicky, so I suggest a sub

    This isn't the most elegant, but IMHO it is the most straight forward. It does R=1 to R=5, but can be expanded
    Maybe someone can come up with an elegant approach

    When you run the sub (click button on worksheet) you enter the R, the data, and the destination location


    BTW, you had a typo in one of your R=3 combinations, and you missed one


    Option Explicit
    
    Sub Combo()
        Dim r As Long
        Dim sCoVar As String
        Dim aCoVar As Variant
        Dim rDest As Range
        Dim i1 As Long, i2 As Long, i3 As Long, i4 As Long, i5 As Long
        Dim aCombi() As String
        Dim iCombi As Long
        
        'inputs
        r = Application.InputBox("What is the R? (Enter as integer, 0 to exit)", "Combinations", 0, , , , , 1)
        If r <= 0 Then Exit Sub
        
        sCoVar = Application.InputBox("What cell has the Covariants serarated by commas? (Blank to exit)", "Combinations", vbNullString, , , , , 8)
        If Len(sCoVar) = 0 Then Exit Sub
        
        Set rDest = Application.InputBox("What cell do you want the results in? (Blank to exit)", "Combinations", vbNullString, , , , , 8)
        If rDest Is Nothing Then Exit Sub
        
        'setup
        sCoVar = Replace(sCoVar, " ", vbNullString)
        aCoVar = Split(sCoVar, ",")     '   0 based
        ReDim aCombi(1 To Application.WorksheetFunction.Combin(UBound(aCoVar) + 1, r))
        
        'calc
        iCombi = 1
        
        Select Case r
            Case 1
                For i1 = 0 To UBound(aCoVar) - r + 1
                    aCombi(iCombi) = aCoVar(i1)
                    iCombi = iCombi + 1
                Next i1
            
            Case 2
                For i1 = 0 To UBound(aCoVar) - r + 1
                    For i2 = i1 + 1 To UBound(aCoVar)
                        aCombi(iCombi) = aCoVar(i1) & ", " & aCoVar(i2)
                        iCombi = iCombi + 1
                    Next i2
                Next i1
            
            Case 3
                For i1 = 0 To UBound(aCoVar) - r + 1
                    For i2 = i1 + 1 To UBound(aCoVar)
                        For i3 = i2 + 1 To UBound(aCoVar)
                            aCombi(iCombi) = aCoVar(i1) & ", " & aCoVar(i2) & ", " & aCoVar(i3)
                            iCombi = iCombi + 1
                        Next i3
                    Next i2
                Next i1
            
            Case 4
                For i1 = 0 To UBound(aCoVar) - r + 1
                    For i2 = i1 + 1 To UBound(aCoVar)
                        For i3 = i2 + 1 To UBound(aCoVar)
                            For i4 = i3 + 1 To UBound(aCoVar)
                                aCombi(iCombi) = aCoVar(i1) & ", " & aCoVar(i2) & ", " & aCoVar(i3) & ", " & aCoVar(i4)
                                iCombi = iCombi + 1
                            Next i4
                        Next i3
                    Next i2
                Next i1
            
            
            Case 5
                For i1 = 0 To UBound(aCoVar) - r + 1
                    For i2 = i1 + 1 To UBound(aCoVar)
                        For i3 = i2 + 1 To UBound(aCoVar)
                            For i4 = i3 + 1 To UBound(aCoVar)
                                For i5 = i4 + 1 To UBound(aCoVar)
                                    aCombi(iCombi) = aCoVar(i1) & ", " & aCoVar(i2) & ", " & aCoVar(i3) & ", " & aCoVar(i4) & ", " & aCoVar(i5)
                                    iCombi = iCombi + 1
                                Next i5
                            Next i4
                        Next i3
                    Next i2
                Next i1
        End Select
        
        
        rDest.Resize(UBound(aCombi), 1).Value = Application.WorksheetFunction.Transpose(aCombi)
    End Sub
    
    Attached Files Attached Files
    Paul

    ------------------------------------------------------------------------------------------------------------------------
    1. Use [CODE] ....[/CODE ] Tags for readability
    [CODE]PasteYourCodeHere[/CODE ] -- (or paste your code, select it, click [#] button)
    2. Upload an example
    Go Advanced / Attachments - Manage Attachments / Add Files / Select Files / Select the file(s)
    (multiple files can be selected while holding Ctrl key) / Upload Files / Done
    3. Mark the thread as [Solved] when you have an answer
    Thread Tools (on the top right corner, above the first message)
    4. Read the Forum FAQ, especially the part about cross-posting in other forums
    http://www.vbaexpress.com/forum/faq...._new_faq_item3

  3. #3
    Distinguished Lord of VBAX VBAX Grand Master xld's Avatar
    Joined
    Apr 2005
    Posts
    25,022
    Location
    Here is one way.

    It is a block array UDF, which means that you select all of the required output cells, input the formula =Combinations(variates_cell,num_groups), and then array-enter, Ctrl-Shift-Enter.

    Option Explicit
    
    Public interim() As Variant
    
    Function Combinations(rng As Range, n As Single)
    Dim items As Variant, final As Variant
    Dim res As Variant
    Dim numItems As Long, numComb As Long, numCells As Long
    Dim i As Long, ii As Long
    
        numCells = Application.Caller.Columns(1).Cells.Count
        
        items = Application.Transpose(Split(rng.Value, ","))
        numItems = UBound(items) - LBound(items) + 1
        ReDim interim(n - 1, 0)
        RecurseItems items, n, 1, 0
        ReDim Preserve interim(UBound(interim, 1), UBound(interim, 2) - 1)
        numComb = Application.Combin(numItems, n)
        ReDim final(1 To numCells)
        
        For i = 0 To Application.Min(numCells - 1, numComb - 1)
        
            res = vbNullString
            For ii = 0 To n - 1
            
                res = res & interim(ii, i) & ","
            Next ii
            final(i + 1) = Left$(res, Len(res) - 1)
        Next i
        
        For i = i To numCells - 1
        
            final(i + 1) = vbNullString
        Next i
        
        Combinations = Application.Transpose(final)
    End Function
    
    Private Function RecurseItems(items As Variant, in1 As Single, in2 As Single, in3 As Single)
    Dim i4 As Long 'f
    Dim i5 As Long 'g
    
        For i4 = in2 To UBound(items, 1)
        
            interim(in3, UBound(interim, 2)) = items(i4, 1)
            
            If in3 = (in1 - 1) Then
            
                ReDim Preserve interim(UBound(interim, 1), UBound(interim, 2) + 1)
                
                For i5 = 0 To UBound(interim, 1)
                
                    interim(i5, UBound(interim, 2)) = interim(i5, UBound(interim, 2) - 1)
                Next i5
            Else
            
                Call RecurseItems(items, in1, i4 + 1, in3 + 1)
            End If
        Next
    End Function
    If you select and enter it into too many cells, the extra cells are filled with null strings, if you select too few cells you will only get as many combinations up to that point.
    ____________________________________________
    Cricket World Cup 2019: Final - England beat New Zealand on boundary count in most thrilling cricket world cup ever

    Nihil simul inventum est et perfectum

    Abusus non tollit usum

    Last night I dreamed of a small consolation enjoyed only by the blind: Nobody knows the trouble I've not seen!
    James Thurber

  4. #4
    Paul!!! You are amazing!!! Thank you so much!

    One more question, if I want to use this for higher r values (up to 9, for example), do I just make a case 6/7/8/9 and sub the desired r value into the code?

    Thank you so much again! Can I give you "reputation" or can I do anything on the forum here to give you credit?

    Quote Originally Posted by Paul_Hossler View Post
    Using a UDF was too finicky, so I suggest a sub

    This isn't the most elegant, but IMHO it is the most straight forward. It does R=1 to R=5, but can be expanded
    Maybe someone can come up with an elegant approach

    When you run the sub (click button on worksheet) you enter the R, the data, and the destination location


    BTW, you had a typo in one of your R=3 combinations, and you missed one


    Option Explicit
    
    Sub Combo()
        Dim r As Long
        Dim sCoVar As String
        Dim aCoVar As Variant
        Dim rDest As Range
        Dim i1 As Long, i2 As Long, i3 As Long, i4 As Long, i5 As Long
        Dim aCombi() As String
        Dim iCombi As Long
        
        'inputs
        r = Application.InputBox("What is the R? (Enter as integer, 0 to exit)", "Combinations", 0, , , , , 1)
        If r <= 0 Then Exit Sub
        
        sCoVar = Application.InputBox("What cell has the Covariants serarated by commas? (Blank to exit)", "Combinations", vbNullString, , , , , 8)
        If Len(sCoVar) = 0 Then Exit Sub
        
        Set rDest = Application.InputBox("What cell do you want the results in? (Blank to exit)", "Combinations", vbNullString, , , , , 8)
        If rDest Is Nothing Then Exit Sub
        
        'setup
        sCoVar = Replace(sCoVar, " ", vbNullString)
        aCoVar = Split(sCoVar, ",")     '   0 based
        ReDim aCombi(1 To Application.WorksheetFunction.Combin(UBound(aCoVar) + 1, r))
        
        'calc
        iCombi = 1
        
        Select Case r
            Case 1
                For i1 = 0 To UBound(aCoVar) - r + 1
                    aCombi(iCombi) = aCoVar(i1)
                    iCombi = iCombi + 1
                Next i1
            
            Case 2
                For i1 = 0 To UBound(aCoVar) - r + 1
                    For i2 = i1 + 1 To UBound(aCoVar)
                        aCombi(iCombi) = aCoVar(i1) & ", " & aCoVar(i2)
                        iCombi = iCombi + 1
                    Next i2
                Next i1
            
            Case 3
                For i1 = 0 To UBound(aCoVar) - r + 1
                    For i2 = i1 + 1 To UBound(aCoVar)
                        For i3 = i2 + 1 To UBound(aCoVar)
                            aCombi(iCombi) = aCoVar(i1) & ", " & aCoVar(i2) & ", " & aCoVar(i3)
                            iCombi = iCombi + 1
                        Next i3
                    Next i2
                Next i1
            
            Case 4
                For i1 = 0 To UBound(aCoVar) - r + 1
                    For i2 = i1 + 1 To UBound(aCoVar)
                        For i3 = i2 + 1 To UBound(aCoVar)
                            For i4 = i3 + 1 To UBound(aCoVar)
                                aCombi(iCombi) = aCoVar(i1) & ", " & aCoVar(i2) & ", " & aCoVar(i3) & ", " & aCoVar(i4)
                                iCombi = iCombi + 1
                            Next i4
                        Next i3
                    Next i2
                Next i1
            
            
            Case 5
                For i1 = 0 To UBound(aCoVar) - r + 1
                    For i2 = i1 + 1 To UBound(aCoVar)
                        For i3 = i2 + 1 To UBound(aCoVar)
                            For i4 = i3 + 1 To UBound(aCoVar)
                                For i5 = i4 + 1 To UBound(aCoVar)
                                    aCombi(iCombi) = aCoVar(i1) & ", " & aCoVar(i2) & ", " & aCoVar(i3) & ", " & aCoVar(i4) & ", " & aCoVar(i5)
                                    iCombi = iCombi + 1
                                Next i5
                            Next i4
                        Next i3
                    Next i2
                Next i1
        End Select
        
        
        rDest.Resize(UBound(aCombi), 1).Value = Application.WorksheetFunction.Transpose(aCombi)
    End Sub
    

  5. #5
    Hi xld,

    Thank you for your reply to my post!

    I did find a code which used an array formula, but it was more labour intensive than finding the combinations for each myself :/

    Paul's code above is exactly what I was looking for! But thank you for your help, I appreciate it
    Quote Originally Posted by xld View Post
    Here is one way.

    It is a block array UDF, which means that you select all of the required output cells, input the formula =Combinations(variates_cell,num_groups), and then array-enter, Ctrl-Shift-Enter.

    Option Explicit
    
    Public interim() As Variant
    
    Function Combinations(rng As Range, n As Single)
    Dim items As Variant, final As Variant
    Dim res As Variant
    Dim numItems As Long, numComb As Long, numCells As Long
    Dim i As Long, ii As Long
    
        numCells = Application.Caller.Columns(1).Cells.Count
        
        items = Application.Transpose(Split(rng.Value, ","))
        numItems = UBound(items) - LBound(items) + 1
        ReDim interim(n - 1, 0)
        RecurseItems items, n, 1, 0
        ReDim Preserve interim(UBound(interim, 1), UBound(interim, 2) - 1)
        numComb = Application.Combin(numItems, n)
        ReDim final(1 To numCells)
        
        For i = 0 To Application.Min(numCells - 1, numComb - 1)
        
            res = vbNullString
            For ii = 0 To n - 1
            
                res = res & interim(ii, i) & ","
            Next ii
            final(i + 1) = Left$(res, Len(res) - 1)
        Next i
        
        For i = i To numCells - 1
        
            final(i + 1) = vbNullString
        Next i
        
        Combinations = Application.Transpose(final)
    End Function
    
    Private Function RecurseItems(items As Variant, in1 As Single, in2 As Single, in3 As Single)
    Dim i4 As Long 'f
    Dim i5 As Long 'g
    
        For i4 = in2 To UBound(items, 1)
        
            interim(in3, UBound(interim, 2)) = items(i4, 1)
            
            If in3 = (in1 - 1) Then
            
                ReDim Preserve interim(UBound(interim, 1), UBound(interim, 2) + 1)
                
                For i5 = 0 To UBound(interim, 1)
                
                    interim(i5, UBound(interim, 2)) = interim(i5, UBound(interim, 2) - 1)
                Next i5
            Else
            
                Call RecurseItems(items, in1, i4 + 1, in3 + 1)
            End If
        Next
    End Function
    If you select and enter it into too many cells, the extra cells are filled with null strings, if you select too few cells you will only get as many combinations up to that point.

  6. #6
    VBAX Wizard
    Joined
    Apr 2007
    Posts
    6,516
    Location
    Quote Originally Posted by Macros_2019 View Post
    Paul!!! You are amazing!!! Thank you so much!

    One more question, if I want to use this for higher r values (up to 9, for example), do I just make a case 6/7/8/9 and sub the desired r value into the code?

    Thank you so much again! Can I give you "reputation" or can I do anything on the forum here to give you credit?

    Thanks for the thought -- you can use the Star for such things; it's nice, but certainly not necessary


    Capture.JPG


    To add higher order, just need to add to the Dim's for i6, …, and handle the additional Case statement


    Look at the ------------------- marked lines in the attachment

    As I said, I know this approach is brute force

    You can mark this [Solved] by using [Thread Tools] to the right and above your first post

    Also, it's possible to convert the 'interactive' sub to one that does not ask for inputs, but gets them from a higher level sub

    Example:

    Call MyCombi (2, Range ("B2"), Range ("M1")) Call MyCombi (3, Range ("C2"), Range ("N1")) Call MyCombi (4, Range ("D2"), Range ("O1"))
    etc
    Attached Files Attached Files
    Paul

    ------------------------------------------------------------------------------------------------------------------------
    1. Use [CODE] ....[/CODE ] Tags for readability
    [CODE]PasteYourCodeHere[/CODE ] -- (or paste your code, select it, click [#] button)
    2. Upload an example
    Go Advanced / Attachments - Manage Attachments / Add Files / Select Files / Select the file(s)
    (multiple files can be selected while holding Ctrl key) / Upload Files / Done
    3. Mark the thread as [Solved] when you have an answer
    Thread Tools (on the top right corner, above the first message)
    4. Read the Forum FAQ, especially the part about cross-posting in other forums
    http://www.vbaexpress.com/forum/faq...._new_faq_item3

  7. #7
    Ok cool, thank you. I've added the higher r values, but it's not allowing me to complete the 3rd step (entering the range, i.e. the cell with the co-variates I want to combine). Would you mind having a quick look at the code and let me know if I've done something wrong?

    OptionExplicit


    Sub Combo()
    Dim r AsLong
        Dim sCoVar As String
        Dim aCoVar As Variant
        Dim rDest As Range
    Dim i1 AsLong, i2 AsLong, i3 AsLong, i4 AsLong, i5 AsLong, i6 AsLong, i7 AsLong, i8 AsLong, i9 AsLong
        Dim aCombi() As String
        Dim iCombi As Long
    
    'inputs
        r = Application.InputBox("What is the R? (Enter as integer, 0 to exit)", "Combinations", 0, , , , , 1)
        If r <= 0 Then Exit Sub
    
        sCoVar = Application.InputBox("What cell has the Covariants serarated by commas? (Blank to exit)", "Combinations", vbNullString, , , , , 8)
        If Len(sCoVar) = 0 Then Exit Sub
    
        Set rDest = Application.InputBox("What cell do you want the results in? (Blank to exit)", "Combinations", vbNullString, , , , , 8)
    If rDest IsNothingThenExitSub
    
    'setup
        sCoVar = Replace(sCoVar, " ", vbNullString)
        aCoVar = Split(sCoVar, ",")     '   0 based
        ReDim aCombi(1 To Application.WorksheetFunction.Combin(UBound(aCoVar) + 1, r))
    
    'calc
        iCombi = 1
    
    SelectCase r
            Case 1
                For i1 = 0 To UBound(aCoVar) - r + 1
                    aCombi(iCombi) = aCoVar(i1)
                    iCombi = iCombi + 1
                Next i1
    
            Case 2
                For i1 = 0 To UBound(aCoVar) - r + 1
                    For i2 = i1 + 1 To UBound(aCoVar)
                        aCombi(iCombi) = aCoVar(i1) & ", " & aCoVar(i2)
                        iCombi = iCombi + 1
                    Next i2
                Next i1
    
            Case 3
                For i1 = 0 To UBound(aCoVar) - r + 1
                    For i2 = i1 + 1 To UBound(aCoVar)
                        For i3 = i2 + 1 To UBound(aCoVar)
                            aCombi(iCombi) = aCoVar(i1) & ", " & aCoVar(i2) & ", " & aCoVar(i3)
                            iCombi = iCombi + 1
                        Next i3
                    Next i2
                Next i1
    
            Case 4
                For i1 = 0 To UBound(aCoVar) - r + 1
                    For i2 = i1 + 1 To UBound(aCoVar)
                        For i3 = i2 + 1 To UBound(aCoVar)
                            For i4 = i3 + 1 To UBound(aCoVar)
                                aCombi(iCombi) = aCoVar(i1) & ", " & aCoVar(i2) & ", " & aCoVar(i3) & ", " & aCoVar(i4)
                                iCombi = iCombi + 1
                            Next i4
                        Next i3
                    Next i2
                Next i1
    
    
            Case 5
                For i1 = 0 To UBound(aCoVar) - r + 1
                    For i2 = i1 + 1 To UBound(aCoVar)
                        For i3 = i2 + 1 To UBound(aCoVar)
                            For i4 = i3 + 1 To UBound(aCoVar)
                                For i5 = i4 + 1 To UBound(aCoVar)
                                    aCombi(iCombi) = aCoVar(i1) & ", " & aCoVar(i2) & ", " & aCoVar(i3) & ", " & aCoVar(i4) & ", " & aCoVar(i5)
                                    iCombi = iCombi + 1
                                Next i5
                            Next i4
                        Next i3
                    Next i2
                Next i1
    
    
            Case 6
                For i1 = 0 To UBound(aCoVar) - r + 1
                    For i2 = i1 + 1 To UBound(aCoVar)
                        For i3 = i2 + 1 To UBound(aCoVar)
                            For i4 = i3 + 1 To UBound(aCoVar)
                                For i5 = i4 + 1 To UBound(aCoVar)
                                    For i6 = i5 + 1 To UBound(aCoVar)
                                        aCombi(iCombi) = aCoVar(i1) & ", " & aCoVar(i2) & ", " & aCoVar(i3) & ", " & aCoVar(i4) & ", " & aCoVar(i5) & ", " & aCoVar(i6)
                                        iCombi = iCombi + 1
                                    Next i6
                                Next i5
                            Next i4
                        Next i3
                    Next i2
                Next i1
    
    
            Case 7
                For i1 = 0 To UBound(aCoVar) - r + 1
                    For i2 = i1 + 1 To UBound(aCoVar)
                        For i3 = i2 + 1 To UBound(aCoVar)
                            For i4 = i3 + 1 To UBound(aCoVar)
                                For i5 = i4 + 1 To UBound(aCoVar)
                                    For i6 = i5 + 1 To UBound(aCoVar)
                                        For i7 = i6 + 1 To UBound(aCoVar)
                                            aCombi(iCombi) = aCoVar(i1) & ", " & aCoVar(i2) & ", " & aCoVar(i3) & ", " & aCoVar(i4) & ", " & aCoVar(i5) & ", " & aCoVar(i6) & ", " & aCoVar(i7)
                                            iCombi = iCombi + 1
                                        Next i7
                                    Next i6
                                Next i5
                            Next i4
                        Next i3
                    Next i2
                Next i1
    
    
            Case 8
                For i1 = 0 To UBound(aCoVar) - r + 1
                    For i2 = i1 + 1 To UBound(aCoVar)
                        For i3 = i2 + 1 To UBound(aCoVar)
                            For i4 = i3 + 1 To UBound(aCoVar)
                                For i5 = i4 + 1 To UBound(aCoVar)
                                    For i6 = i5 + 1 To UBound(aCoVar)
                                        For i7 = i6 + 1 To UBound(aCoVar)
                                            For i8 = i7 + 1 To UBound(aCoVar)
                                                 aCombi(iCombi) = aCoVar(i1) & ", " & aCoVar(i2) & ", " & aCoVar(i3) & ", " & aCoVar(i4) & ", " & aCoVar(i5)
                                                 iCombi = iCombi + 1
                                              Next i8
                                          Next i7
                                      Next i6
                                  Next i5
                              Next i4
                          Next i3
                      Next i2
                  Next i1
    EndSelect
    
    
        rDest.Resize(UBound(aCombi), 1).Value = Application.WorksheetFunction.Transpose(aCombi)
    EndSub
    
    
    
    I don't seem to have a star on my screen (see attached screenshot), wonder if this is because my account is new?

    Thanks so much again
    Screen Shot 2019-04-17 at 20.16.25.jpg

    Quote Originally Posted by Paul_Hossler View Post
    Thanks for the thought -- you can use the Star for such things; it's nice, but certainly not necessary


    Capture.JPG


    To add higher order, just need to add to the Dim's for i6, …, and handle the additional Case statement


    Look at the ------------------- marked lines in the attachment

    As I said, I know this approach is brute force

    You can mark this [Solved] by using [Thread Tools] to the right and above your first post

    Also, it's possible to convert the 'interactive' sub to one that does not ask for inputs, but gets them from a higher level sub

    Example:

    Call MyCombi (2, Range ("B2"), Range ("M1")) Call MyCombi (3, Range ("C2"), Range ("N1")) Call MyCombi (4, Range ("D2"), Range ("O1"))
    etc

  8. #8
    Sorry I didn't wrap the code in my last post. I'm now getting a compile error (Case without select case) when I try to run it :

    OptionExplicit
    
    
    Sub Combo()
    Dim r AsLong
        Dim sCoVar As String
        Dim aCoVar As Variant
        Dim rDest As Range
    Dim i1 AsLong, i2 AsLong, i3 AsLong, i4 AsLong, i5 AsLong
        Dim aCombi() As String
        Dim iCombi As Long
    
    'inputs
        r = Application.InputBox("What is the R? (Enter as integer, 0 to exit)", "Combinations", 0, , , , , 1)
        If r <= 0 Then Exit Sub
    
        sCoVar = Application.InputBox("What cell has the Covariants serarated by commas? (Blank to exit)", "Combinations", vbNullString, , , , , 8)
        If Len(sCoVar) = 0 Then Exit Sub
    
        Set rDest = Application.InputBox("What cell do you want the results in? (Blank to exit)", "Combinations", vbNullString, , , , , 8)
    If rDest IsNothingThenExitSub
    
    'setup
        sCoVar = Replace(sCoVar, " ", vbNullString)
        aCoVar = Split(sCoVar, ",")     '   0 based
        ReDim aCombi(1 To Application.WorksheetFunction.Combin(UBound(aCoVar) + 1, r))
    
    'calc
        iCombi = 1
    
    SelectCase r
            Case 1
                For i1 = 0 To UBound(aCoVar) - r + 1
                    aCombi(iCombi) = aCoVar(i1)
                    iCombi = iCombi + 1
                Next i1
    
            Case 2
                For i1 = 0 To UBound(aCoVar) - r + 1
                    For i2 = i1 + 1 To UBound(aCoVar)
                        aCombi(iCombi) = aCoVar(i1) & ", " & aCoVar(i2)
                        iCombi = iCombi + 1
                    Next i2
                Next i1
    
            Case 3
                For i1 = 0 To UBound(aCoVar) - r + 1
                    For i2 = i1 + 1 To UBound(aCoVar)
                        For i3 = i2 + 1 To UBound(aCoVar)
                            aCombi(iCombi) = aCoVar(i1) & ", " & aCoVar(i2) & ", " & aCoVar(i3)
                            iCombi = iCombi + 1
                        Next i3
                    Next i2
                Next i1
    
            Case 4
                For i1 = 0 To UBound(aCoVar) - r + 1
                    For i2 = i1 + 1 To UBound(aCoVar)
                        For i3 = i2 + 1 To UBound(aCoVar)
                            For i4 = i3 + 1 To UBound(aCoVar)
                                aCombi(iCombi) = aCoVar(i1) & ", " & aCoVar(i2) & ", " & aCoVar(i3) & ", " & aCoVar(i4)
                                iCombi = iCombi + 1
                            Next i4
                        Next i3
                    Next i2
                Next i1
    
    
            Case 5
                For i1 = 0 To UBound(aCoVar) - r + 1
                    For i2 = i1 + 1 To UBound(aCoVar)
                        For i3 = i2 + 1 To UBound(aCoVar)
                            For i4 = i3 + 1 To UBound(aCoVar)
                                For i5 = i4 + 1 To UBound(aCoVar)
                                    aCombi(iCombi) = aCoVar(i1) & ", " & aCoVar(i2) & ", " & aCoVar(i3) & ", " & aCoVar(i4) & ", " & aCoVar(i5)
                                    iCombi = iCombi + 1
                                Next i5
                            Next i4
                        Next i3
                    Next i2
                Next i1
    EndSelect
    
    
            Case 6
                For i1 = 0 To UBound(aCoVar) - r + 1
                    For i2 = i1 + 1 To UBound(aCoVar)
                        For i3 = i2 + 1 To UBound(aCoVar)
                            For i4 = i3 + 1 To UBound(aCoVar)
                                For i5 = i4 + 1 To UBound(aCoVar)
                                    For i6 = i5 + 1 To UBound(aCoVar)
                                        aCombi(iCombi) = aCoVar(i1) & ", " & aCoVar(i2) & ", " & aCoVar(i3) & ", " & aCoVar(i4) & ", " & aCoVar(i5) & “, “ & aCoVar(i6)
                                        iCombi = iCombi + 1
                                    Next i6
                                 Next i5
                             Next i4
                          Next i3
                       Next i2
                    Next i1
    EndSelect
    
    
            Case 7
                For i1 = 0 To UBound(aCoVar) - r + 1
                    For i2 = i1 + 1 To UBound(aCoVar)
                        For i3 = i2 + 1 To UBound(aCoVar)
                            For i4 = i3 + 1 To UBound(aCoVar)
                                For i5 = i4 + 1 To UBound(aCoVar)
                                    For i6 = i5 + 1 To UBound(aCoVar)
                                        For i7 = i6 + 1 To UBound(aCoVar)
                                            aCombi(iCombi) = aCoVar(i1) & ", " & aCoVar(i2) & ", " & aCoVar(i3) & ", " & aCoVar(i4) & ", " & aCoVar(i5) & ”, ” & aCoVar(i6) & ”, ” & aCoVar(i7)
                                            iCombi = iCombi + 1
                                        Next i7
                                     Next i6
                                  Next i5
                               Next i4
                            Next i3
                         Next i2
                      Next i1
              End Select
    
    
            Case 8
                For i1 = 0 To UBound(aCoVar) - r + 1
                    For i2 = i1 + 1 To UBound(aCoVar)
                        For i3 = i2 + 1 To UBound(aCoVar)
                            For i4 = i3 + 1 To UBound(aCoVar)
                                For i5 = i4 + 1 To UBound(aCoVar)
                                    For i6 = i5 + 1 To UBound(aCoVar)
                                        For i7 = i6 + 1 To UBound(aCoVar)
                                            For i8 = i7 + 1 To UBound(aCoVar)
                                                aCombi(iCombi) = aCoVar(i1) & ", " & aCoVar(i2) & ", " & aCoVar(i3) & ", " & aCoVar(i4) & ", " & aCoVar(i5) & ”, ” & aCoVar(i6) & ”, ” & aCoVar(i7) & ”, ” & aCoVar(i8)
                                                iCombi = iCombi + 1
                                            Next i8
                                         Next i7
                                      Next i6
                                   Next i5
                                Next i4
                             Next i3
                          Next i2
                       Next i1
               End Select
    
    
        rDest.Resize(UBound(aCombi), 1).Value = Application.WorksheetFunction.Transpose(aCombi)
    EndSub

  9. #9
    Got it working now!!

    OptionExplicit
    
    
    Sub Combo()
    Dim r AsLong
        Dim sCoVar As String
        Dim aCoVar As Variant
        Dim rDest As Range
    Dim i1 AsLong, i2 AsLong, i3 AsLong, i4 AsLong, i5 AsLong, i6 AsLong, i7 AsLong, i8 AsLong
        Dim aCombi() As String
        Dim iCombi As Long
    
    'inputs
        r = Application.InputBox("What is the R? (Enter as integer, 0 to exit)", "Combinations", 0, , , , , 1)
        If r <= 0 Then Exit Sub
    
        sCoVar = Application.InputBox("What cell has the Covariants serarated by commas? (Blank to exit)", "Combinations", vbNullString, , , , , 8)
        If Len(sCoVar) = 0 Then Exit Sub
    
        Set rDest = Application.InputBox("What cell do you want the results in? (Blank to exit)", "Combinations", vbNullString, , , , , 8)
    If rDest IsNothingThenExitSub
    
    'setup
        sCoVar = Replace(sCoVar, " ", vbNullString)
        aCoVar = Split(sCoVar, ",")     '   0 based
        ReDim aCombi(1 To Application.WorksheetFunction.Combin(UBound(aCoVar) + 1, r))
    
    'calc
        iCombi = 1
    
    SelectCase r
            Case 1
                For i1 = 0 To UBound(aCoVar) - r + 1
                    aCombi(iCombi) = aCoVar(i1)
                    iCombi = iCombi + 1
                Next i1
    
            Case 2
                For i1 = 0 To UBound(aCoVar) - r + 1
                    For i2 = i1 + 1 To UBound(aCoVar)
                        aCombi(iCombi) = aCoVar(i1) & ", " & aCoVar(i2)
                        iCombi = iCombi + 1
                    Next i2
                Next i1
    
            Case 3
                For i1 = 0 To UBound(aCoVar) - r + 1
                    For i2 = i1 + 1 To UBound(aCoVar)
                        For i3 = i2 + 1 To UBound(aCoVar)
                            aCombi(iCombi) = aCoVar(i1) & ", " & aCoVar(i2) & ", " & aCoVar(i3)
                            iCombi = iCombi + 1
                        Next i3
                    Next i2
                Next i1
    
            Case 4
                For i1 = 0 To UBound(aCoVar) - r + 1
                    For i2 = i1 + 1 To UBound(aCoVar)
                        For i3 = i2 + 1 To UBound(aCoVar)
                            For i4 = i3 + 1 To UBound(aCoVar)
                                aCombi(iCombi) = aCoVar(i1) & ", " & aCoVar(i2) & ", " & aCoVar(i3) & ", " & aCoVar(i4)
                                iCombi = iCombi + 1
                            Next i4
                        Next i3
                    Next i2
                Next i1
    
    
            Case 5
                For i1 = 0 To UBound(aCoVar) - r + 1
                    For i2 = i1 + 1 To UBound(aCoVar)
                        For i3 = i2 + 1 To UBound(aCoVar)
                            For i4 = i3 + 1 To UBound(aCoVar)
                                For i5 = i4 + 1 To UBound(aCoVar)
                                    aCombi(iCombi) = aCoVar(i1) & ", " & aCoVar(i2) & ", " & aCoVar(i3) & ", " & aCoVar(i4) & ", " & aCoVar(i5)
                                    iCombi = iCombi + 1
                                Next i5
                            Next i4
                        Next i3
                    Next i2
                Next i1
    
    
            Case 6
                For i1 = 0 To UBound(aCoVar) - r + 1
                    For i2 = i1 + 1 To UBound(aCoVar)
                        For i3 = i2 + 1 To UBound(aCoVar)
                            For i4 = i3 + 1 To UBound(aCoVar)
                                For i5 = i4 + 1 To UBound(aCoVar)
                                    For i6 = i5 + 1 To UBound(aCoVar)
                                        aCombi(iCombi) = aCoVar(i1) & ", " & aCoVar(i2) & ", " & aCoVar(i3) & ", " & aCoVar(i4) & ", " & aCoVar(i5) & ", " & aCoVar(i6)
                                        iCombi = iCombi + 1
                                    Next i6
                                Next i5
                            Next i4
                        Next i3
                    Next i2
                Next i1
    
    
            Case 7
                For i1 = 0 To UBound(aCoVar) - r + 1
                    For i2 = i1 + 1 To UBound(aCoVar)
                        For i3 = i2 + 1 To UBound(aCoVar)
                            For i4 = i3 + 1 To UBound(aCoVar)
                                For i5 = i4 + 1 To UBound(aCoVar)
                                    For i6 = i5 + 1 To UBound(aCoVar)
                                        For i7 = i6 + 1 To UBound(aCoVar)
                                            aCombi(iCombi) = aCoVar(i1) & ", " & aCoVar(i2) & ", " & aCoVar(i3) & ", " & aCoVar(i4) & ", " & aCoVar(i5) & ", " & aCoVar(i6) & ", " & aCoVar(i7)
                                            iCombi = iCombi + 1
                                        Next i7
                                    Next i6
                                Next i5
                            Next i4
                        Next i3
                    Next i2
                Next i1
    
    
            Case 8
                For i1 = 0 To UBound(aCoVar) - r + 1
                    For i2 = i1 + 1 To UBound(aCoVar)
                        For i3 = i2 + 1 To UBound(aCoVar)
                            For i4 = i3 + 1 To UBound(aCoVar)
                                For i5 = i4 + 1 To UBound(aCoVar)
                                    For i6 = i5 + 1 To UBound(aCoVar)
                                        For i7 = i6 + 1 To UBound(aCoVar)
                                            For i8 = i7 + 1 To UBound(aCoVar)
                                                aCombi(iCombi) = aCoVar(i1) & ", " & aCoVar(i2) & ", " & aCoVar(i3) & ", " & aCoVar(i4) & ", " & aCoVar(i5) & ", " & aCoVar(i6) & ", " & aCoVar(i7) & ", " & aCoVar(i8)
                                                iCombi = iCombi + 1
                                            Next i8
                                        Next i7
                                    Next i6
                                Next i5
                            Next i4
                        Next i3
                    Next i2
                Next i1
    EndSelect
    
    
        rDest.Resize(UBound(aCombi), 1).Value = Application.WorksheetFunction.Transpose(aCombi)
    EndSub
    Thank you so so much for your help, Paul!

  10. #10
    VBAX Mentor 大灰狼1976's Avatar
    Joined
    Dec 2018
    Location
    SuZhou China
    Posts
    381
    Location
    Hi Macros!
    A Self-Considered Elegant Processing Method.
    Please refer to the attachment.
    Function CombinationsTest(arr, r&)
    Dim arrOri, arrRst, rw&, i&, j&, k&, st&, en&, n&
    ReDim arrOri(0, 1)
    en = UBound(arr) - r + 1
    For i = 0 To r - 1
      n = n + 1: rw = 0
      ReDim arrRst(Application.Combin(en + 1, n) - 1, 1)
      For j = 0 To UBound(arrOri)
        st = arrOri(j, 1)
        For k = st To en
          arrRst(rw, 0) = arrOri(j, 0) & IIf(arrOri(j, 0) = "", "", ",") & arr(k)
          arrRst(rw, 1) = k + 1
          rw = rw + 1
        Next k
      Next j
      arrOri = arrRst
      en = en + 1
    Next i
    CombinationsTest = arrRst
    End Function


    --Okami
    Attached Files Attached Files

  11. #11
    VBAX Mentor 大灰狼1976's Avatar
    Joined
    Dec 2018
    Location
    SuZhou China
    Posts
    381
    Location
    A little more improvement.
    arrRst(rw, 0) = arrOri(j, 0) & IIf(i = 0, "", ",") & arr(k)

  12. #12
    VBAX Mentor 大灰狼1976's Avatar
    Joined
    Dec 2018
    Location
    SuZhou China
    Posts
    381
    Location
    Adding a recursive algorithm, please refer to the attachment.
    Attached Files Attached Files

Tags for this Thread

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •