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，因为这个数字是我所说的一部分＆＃34;一个集合＆＃34;，由同一个字母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三维中，x在长度为2，y的长度为3，z的长度为2，如果是n的x，y和z元素，则有12个可能的点（x，y，z）。

为了遍历维度中的所有地址，通常使用嵌套循环。所以我也会这样做。

enter image description here

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

获得所有组合

1 个答案: