Get all combinations - vba

Question

I would like to generate all possible vectors where minimum and maximum of each element is known and some set of elements can have only the same value.
For example I have an input like this:
rid Set MaxId
1 a 1
2 b 2
3 c 2
4 c 2
5 c 2
Set identifies elements which all should always have the same value, MaxId identifies maximum integer atribute can have, minimum is always 1. From this data, we can create the following 4 combinations (denoted c1 - c4):
rid Set c1 c2 c3 c4
1 a 1 1 1 1
2 b 1 1 2 2
3 c 1 2 1 2
4 c 1 2 1 2
5 c 1 2 1 2
How can I do this using VBA? In my real data I have 100 rows with 5 different sets, resulting in total 80 variables where max Id is ranging between 1 and 5.
The example above is complete, there is no additional input to be provided. Let's consider different example:
rid Set MaxId
1 a 2
2 b 1
3 c 3
4 c 3
5 c 3
This would result in 6 possible combinations (2 x 1 x 3). There is only one 3 as this number is part of what I call "a set", identified by same letter c. The possible combinations are:
rid Set c1 c2 c3 c4 c5 c6
1 a 1 2 1 1 2 2
2 b 1 1 1 1 1 1
3 c 1 1 2 3 2 3
4 c 1 1 2 3 2 3
5 c 1 1 2 3 2 3

Answer 1

If I understand it right, then I would call your "sets" dimensions and your combinations possible addresses in those dimensions. For example in two dimensions x and y where x is in length 2 and y is in length 3 there are 6 possible points(x,y) if x and y elements of N. In three dimensions x, y and z where x is in length 2, y is in length 3 and z is in length 2 there are 12 possible points(x,y,z) if x, y and z elements of N.
For going through all addresses in dimensions normally nested loops are used. So I would do this here also.
Sub Dimensions()
With ThisWorkbook.Worksheets(1)
'create a dictionary for up to 5 different dimensions named "a" to "e"
'and their max length values
'using dictionary because mapping key (dimension name) to value (max length value)
Set dDimensions = CreateObject("Scripting.Dictionary")
dDimensions.Add "a", 9999 '9999 is the stop value which shows that this Dimension is not used
dDimensions.Add "b", 9999
dDimensions.Add "c", 9999
dDimensions.Add "d", 9999
dDimensions.Add "e", 9999
'get the dimension definitions from A2:B[n]
r = 2
Do While .Cells(r, 1) <> ""
sDimension = .Cells(r, 1).Value
lMax = .Cells(r, 2).Value
If lMax > 0 And dDimensions.exists(sDimension) Then
'if inconsistent definitions for length of dimensions exists,
'for example "a" with max length 3 and "a" with max length 2,
'then take the lowest max length definition, in example "a" with 2
If dDimensions.Item(sDimension) > lMax Then dDimensions.Item(sDimension) = lMax
End If
r = r + 1
Loop
'calculate the count of possible combinations
lCount = 1
For Each sDimension In dDimensions
lMax = dDimensions.Item(sDimension)
If lMax < 9999 Then lCount = lCount * lMax
Next
'create a dictionary for the results
'up to 5 different Dimensions named "a" to "e"
'and their possible values in lCount possible combinations
Set dResults = CreateObject("Scripting.Dictionary")
Dim aPointAddresses() As Long
ReDim aPointAddresses(lCount - 1)
dResults.Add "a", aPointAddresses
dResults.Add "b", aPointAddresses
dResults.Add "c", aPointAddresses
dResults.Add "d", aPointAddresses
dResults.Add "e", aPointAddresses
'go through all possible addresses and fill the dResults
lCount = 0
For a = 1 To dDimensions.Item("a")
For b = 1 To dDimensions.Item("b")
For c = 1 To dDimensions.Item("c")
For d = 1 To dDimensions.Item("d")
For e = 1 To dDimensions.Item("e")
If dDimensions.Item("a") < 9999 Then
arr = dResults.Item("a")
arr(lCount) = a
dResults.Item("a") = arr
End If
If dDimensions.Item("b") < 9999 Then
arr = dResults.Item("b")
arr(lCount) = b
dResults.Item("b") = arr
End If
If dDimensions.Item("c") < 9999 Then
arr = dResults.Item("c")
arr(lCount) = c
dResults.Item("c") = arr
End If
If dDimensions.Item("d") < 9999 Then
arr = dResults.Item("d")
arr(lCount) = d
dResults.Item("d") = arr
End If
If dDimensions.Item("e") < 9999 Then
arr = dResults.Item("e")
arr(lCount) = e
dResults.Item("e") = arr
End If
lCount = lCount + 1
If dDimensions.Item("e") = 9999 Then Exit For
Next
If dDimensions.Item("d") = 9999 Then Exit For
Next
If dDimensions.Item("c") = 9999 Then Exit For
Next
If dDimensions.Item("b") = 9999 Then Exit For
Next
If dDimensions.Item("a") = 9999 Then Exit For
Next
'now dResults contains an array of possible point addresses for each used dimension
'key:="dimension", item:={p1Addr, p2Addr, p3Addr, ..., pNAddr}
'clear the result range
.Range("D:XFD").Clear
'print out the results in columns D:XFD
.Range("D1").Value = "p1"
.Range("D1").AutoFill Destination:=.Range("D1:XFD1")
r = 2
Do While .Cells(r, 1) <> ""
sDimension = .Cells(r, 1).Value
arr = dResults.Item(sDimension)
.Range(.Cells(r, 4), .Cells(r, 4 + UBound(arr))).Value = arr
r = r + 1
Loop
End With
End Sub