Combinations of 3 from 16 numbers pool with unique product

[libelouli]

Hi.
I have these 16 numbers : 2 , 3 , 4 , 5 , 6 , 7 , 8 , 10 , 15 , 20 , 25 , 30 , 40 , 50 , 100 , 500 and I want to display in excel VBA all the combinations of threes.The product of threes I want to be unique.I use Excel 2010.
Example :
Column A - Column B - Colmn C - Column D
2 3 4 24
2 3 5 30
2 3 6 36
2 3 7 42 ...etc,etc.Column D resaults must be unique.
I found with an online calculator that all combinations is 560.So I asume that many of them will have the same product of three which I don't want.
Can anyone help how to manage this?
Thanks in advanced for your time.

 

[igold]

Although I do not have an answer to your question. As an FYI, you can easily figure out the number of unique combinations like this: if you are using 16 numbers and you want unique combinations of three the simple formula you can plug into excel would be:

=(16*15*14)/(1*2*3)

As another example so you can see the pattern- If you were using 20 numbers with combinations of 5 numbers each, the formula would be (for unique combinations):

=(20*19*18*17*16)/(1*2*3*4*5)

Edit: I did not think that Excel 2010 had the "Combin" function, but it does. Clearly you could of used that instead of an online calculator or my sample as shown.

 

[Cubist]

Are repetitions allowed e.g. 2,2,2?

 

[igold]

@Cubist - I would assume not as he gave the number of combinations as 560.

 

[Cubist]

Try this (assuming no repetitions).

Sub GenerateCombinations()
    Dim ws As Worksheet
    Set ws = ThisWorkbook.Sheets(1)
    Dim inputRange As Range
    Dim outputArray() As Variant
    Dim i As Long, j As Long, k As Long
    Dim n As Long
    Dim numbers() As Variant
    Dim outputRow As Long
    Dim totalCombinations As Long
    
    'Assuming the numbers are in column A starting from A1
    numbers = ws.Range("A1:A" & ws.Cells(ws.Rows.Count, "A").End(xlUp).Row).Value
    n = UBound(numbers, 1)

    totalCombinations = (n * (n - 1) * (n - 2)) / 6
    ReDim outputArray(1 To totalCombinations, 1 To 4)
    outputRow = 1
    For i = 1 To n - 2
        For j = i + 1 To n - 1
            For k = j + 1 To n
                outputArray(outputRow, 1) = numbers(i, 1)
                outputArray(outputRow, 2) = numbers(j, 1)
                outputArray(outputRow, 3) = numbers(k, 1)
                outputArray(outputRow, 4) = numbers(i, 1) * numbers(j, 1) * numbers(k, 1)
                outputRow = outputRow + 1
            Next k
        Next j
    Next i
    'Output
    ws.Range("B1").Resize(totalCombinations, 4).Value = outputArray
End Sub

 

[Cubist]

Although I do not have an answer to your question. As an FYI, you can easily figure out the number of unique combinations like this: if you are using 16 numbers and you want unique combinations of three the simple formula you can plug into excel would be:

=(16*15*14)/(1*2*3)

As another example so you can see the pattern- If you were using 20 numbers with combinations of 5 numbers each, the formula would be (for unique combinations):

=(20*19*18*17*16)/(1*2*3*4*5)

Edit: I did not think that Excel 2010 had the "Combin" function, but it does. Clearly you could of used that instead of an online calculator or my sample as shown.

There's a built-in formula in Excel.

=COMBIN(16,3)

 

[igold]

Yes, I know. I edited my comment with that fact a while ago. Nonetheless, it never hurts to know how to do it manually...

 

[igold]

@Cubist - you solution contains duplicate products. The OP asked for unique products... Easy enough to put your results into the Unique function as a workaround.

 

[Cubist]

In later version of Excel you can use UNIQUE function, but added VBA to output into col F.

Sub GenerateCombinations()
    Dim ws As Worksheet
    Set ws = ThisWorkbook.Sheets(1) 'change sheet name as needed
    Dim inputRange As Range
    Dim outputArray() As Variant
    Dim uniqueProducts As Object
    Dim i As Long, j As Long, k As Long
    Dim n As Long
    Dim numbers() As Variant
    Dim outputRow As Long
    Dim totalCombinations As Long
    Dim product As Double
    ' Assuming the numbers are in column A starting from A1
    numbers = ws.Range("A1:A" & ws.Cells(ws.Rows.Count, "A").End(xlUp).Row).Value
    n = UBound(numbers, 1)
    totalCombinations = Application.Combin(n, 3)
    ReDim outputArray(1 To totalCombinations, 1 To 4)
    Set uniqueProducts = CreateObject("Scripting.Dictionary")
    outputRow = 1
    For i = 1 To n - 2
        For j = i + 1 To n - 1
            For k = j + 1 To n
                outputArray(outputRow, 1) = numbers(i, 1)
                outputArray(outputRow, 2) = numbers(j, 1)
                outputArray(outputRow, 3) = numbers(k, 1)
                product = numbers(i, 1) * numbers(j, 1) * numbers(k, 1)
                outputArray(outputRow, 4) = product
                If Not uniqueProducts.Exists(CStr(product)) Then
                    uniqueProducts.Add CStr(product), product
                End If
                outputRow = outputRow + 1
            Next k
        Next j
    Next i
    'Check unique products
    Dim uniqueArray() As Variant
    Dim uniqueRow As Long
    ReDim uniqueArray(1 To uniqueProducts.Count, 1 To 1)
    uniqueRow = 1
    For Each p In uniqueProducts.Items
        uniqueArray(uniqueRow, 1) = p
        uniqueRow = uniqueRow + 1
    Next p
    
    ' Output
    ws.Range("B1").Resize(totalCombinations, 4).Value = outputArray
    ws.Range("F1").Resize(uniqueProducts.Count, 1).Value = uniqueArray
End Sub

 

[Eric W]

Here's another option:

Sub GetProducts()
Dim Nums As Variant, NumToCombine As Long, res As Object, ShowAll As Boolean

    Nums = Range("A1", Range("A1").End(xlDown)).Value               ' Will include all numbers from A1 to the first empty cell
    NumToCombine = 3                                                ' How many numbers to multiply together?
    Set res = CreateObject("Scripting.Dictionary")                  ' Create result dictionary
    ShowAll = False                                                 ' Show all combinations?  Or just the products and counts?
    
    Call recur(Nums, NumToCombine, 1, 0, 0, "", res, ShowAll)       ' Start
    
    Range("C1").Resize(res.Count).Value = WorksheetFunction.Transpose(res.keys)     ' Show first column
    Range("D1").Resize(res.Count).Value = WorksheetFunction.Transpose(res.items)    ' Show second column
    
    If Not ShowAll Then Columns("C:D").Sort key1:=Range("C1"), order1:=xlAscending, Header:=xlNo    ' If only products, sort
    
End Sub

Sub recur(ByRef Nums, ByRef NumToCombine, ByVal product, ByVal depth, ByVal loc, ByVal str, ByRef res, ByRef ShowAll)
Dim i As Long

    If depth = NumToCombine Then                ' Hit the limit?
        If ShowAll Then                         ' Show all?
            Mid(str, Len(str), 1) = "="         ' Yes, convert the last * to a =
            res.Add str, product                ' Add to the result array
        Else
            res(product) = res(product) + 1     ' If just a product, increment the counter
        End If
        Exit Sub
    End If
    
    For i = loc + 1 To UBound(Nums)             ' Go another level deep if needed
        Call recur(Nums, NumToCombine, product * Nums(i, 1), depth + 1, i, str & Nums(i, 1) & "*", res, ShowAll)
    Next i
    
End Sub

Based on the setting of the ShowAll variable, it will show all combinations, or if False, will just show the products and a count of how many combinations end up with each product. I wasn't sure if I should show one representative set of numbers for each product or not, but that can be added easily enough. All I/O is on the active sheet.