獲取所有組合

Question

我想生成所有可能的向量，其中每個元素的最小值和最大值是已知的，而某些元素集只能具有相同的值。

例如我有一個這樣的輸入：

rid Set MaxId 
1  a  1 
2  b  2 
3  c  2 
4  c  2 
5  c  2 

集識別哪個都應該總是具有相同的值的元件，MaxId標識最大整數屬性附加傷害可以具有最小始終是1。從這些數據，我們可以創建以下4種組合（表示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 

我怎樣才能做到這一點使用VBA？在我的實際數據中，我有100行，5個不同的集合，導致總共80個變量，其中最大Id在1和5之間。

上述示例已完成，沒有其他輸入需要提供。讓我們考慮一個不同的例子：

rid Set MaxId 
1  a  2 
2  b  1 
3  c  3 
4  c  3 
5  c  3 

這將導致6種可能的組合（2 x 1 x 3）。只有一個3，因爲這個數字是我所謂的「一組」，由相同的字母c確定的一部分。可能的組合有：

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

在這些方面如果我的理解是正確的，那麼我會打電話給你「套」的尺寸和你的組合可能的地址。例如，在x和y兩個維度中，其中x的長度爲2，y的長度爲3，如果N的x和y元素有6個可能的點（x，y）。在x，y和z三個維度中長度2，y長度爲3，z長度爲2，如果x，y和z元素爲N，則有12個可能點（x，y，z）。

對於通過維度的所有地址，通常嵌套循環被使用。所以我也會這樣做。

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