0

我正在分层，将我的选项堆叠在 excel 中。我以类似的方式提出了这个问题，但是我现在想在其中添加更多细节。如果我有 n 个要堆叠的盒子，堆叠它们的可能选项是 2^n-1。让我举一个 3 个盒子的例子，我们给它们命名为 A、B、C 和 D。它们的堆叠方式无关紧要，即 AB=BA 和 ABC=CAB，它们算作 1 个堆叠选项。结果将是：

A、B、C、AB、BC、AC、ABC

现在我想创建一个 excel 文件，我将在其中输入框字母，它为我提供了所有堆叠可能性的列表。所以我会提供盒子的数量和字母。（3 个框，A、B、C）Excel 会读入并在单元格中为我提供选项。

是否可以在彼此下方连续获得选项？对于 n 个盒子？

这可能吗？谁能帮我这个？

提前谢谢你！

4

1 回答 1

1

一些代码修改自 Tony Dallimore 关于从数组创建所有可能的唯一组合的列表（使用 VBA）的帖子

用法：

  1. 在宏“stackBox”中——将“Sheet1”更改为您想要的工作表名称

  2. 输入单元格 A1 中的框数

  3. 在B1，C1，...等中输入名称..

  4. 调用堆栈框

“Sheet1”中的输入格式和输出结果：

3   A   B   C   D   E
A                   
B                   
AB                  
C                   
AC                  
BC                  
ABC                 
D                   
AD                  
BD                  
ABD                 
CD                  
ACD                 
BCD                 
E                   
AE                  
BE                  
ABE                 
CE                  
ACE                 
BCE                 
DE                  
ADE                 
BDE                 
CDE

编码：

 Function stackBox()
    Dim ws As Worksheet
    Dim width As Long
    Dim height As Long
    Dim numOfBox As Long
    Dim optionsA() As Variant
    Dim results() As Variant
    Dim str As String
    Dim outputArray As Variant
    Dim i As Long, j As Long
    Set ws = Worksheets("Sheet1")
    With ws
        'clear last time's output
        height = .Cells(.Rows.Count, 1).End(xlUp).row
        If height > 1 Then
            .Range(.Cells(2, 1), .Cells(height, 1)).ClearContents
        End If

        numOfBox = .Cells(1, 1).Value
        width = .Cells(1, .Columns.Count).End(xlToLeft).Column
        If width < 2 Then
            MsgBox "Error: There's no item, please fill your item in Cell B1,C1,..."
            Exit Function
        End If
        ReDim optionsA(0 To width - 2)
        For i = 0 To width - 2
            optionsA(i) = .Cells(1, i + 2).Value
        Next i

        GenerateCombinations optionsA, results, numOfBox


        ' copy the result to sheet only once
        ReDim outputArray(1 To UBound(results, 1) - LBound(results, 1) + 1, 1 To 1)
        Count = 0
        For i = LBound(results, 1) To UBound(results, 1)
            If Not IsEmpty(results(i)) Then
                'rowNum = rowNum + 1
                str = ""

                For j = LBound(results(i), 1) To UBound(results(i), 1)
                    str = str & results(i)(j)
                Next j
                Count = Count + 1
                outputArray(Count, 1) = str
            '.Cells(rowNum, 1).Value = str
            End If
        Next i
        .Range(.Cells(2, 1), .Cells(UBound(outputArray, 1) + 1, 1)).Value = outputArray
    End With

End Function

Sub GenerateCombinations(ByRef AllFields() As Variant, _
                                             ByRef Result() As Variant, ByVal numOfBox As Long)

  Dim InxResultCrnt As Integer
  Dim InxField As Integer
  Dim InxResult As Integer
  Dim i As Integer
  Dim NumFields As Integer
  Dim Powers() As Integer
  Dim ResultCrnt() As String

  NumFields = UBound(AllFields) - LBound(AllFields) + 1

  ReDim Result(0 To 2 ^ NumFields - 2)  ' one entry per combination
  ReDim Powers(0 To NumFields - 1)          ' one entry per field name

  ' Generate powers used for extracting bits from InxResult
  For InxField = 0 To NumFields - 1
    Powers(InxField) = 2 ^ InxField
  Next

 For InxResult = 0 To 2 ^ NumFields - 2
    ' Size ResultCrnt to the max number of fields per combination
    ' Build this loop's combination in ResultCrnt

    ReDim ResultCrnt(0 To NumFields - 1)
    InxResultCrnt = -1
    For InxField = 0 To NumFields - 1
      If ((InxResult + 1) And Powers(InxField)) <> 0 Then
        ' This field required in this combination
        InxResultCrnt = InxResultCrnt + 1
        ResultCrnt(InxResultCrnt) = AllFields(InxField)
      End If
    Next

    If InxResultCrnt = 0 Then
        Debug.Print "testing"
    End If
    'additional logic here
    If InxResultCrnt >= numOfBox Then
        Result(InxResult) = Empty

    Else
         ' Discard unused trailing entries
        ReDim Preserve ResultCrnt(0 To InxResultCrnt)
        ' Store this loop's combination in return array
        Result(InxResult) = ResultCrnt
    End If

  Next

End Sub
于 2012-10-18T09:34:16.303 回答