Question

我正在分层，在Excel中堆叠我的选项。我以类似的方式提出了这个问题，但是现在我想在其中加入一些细节。如果我有多个盒子要堆叠，堆叠它们的可能选项是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个盒子？

这可能吗？任何人都可以帮我这个吗？

先谢谢你了！

Answer 1

根据Tony Dallimore在Creating a list of all possible unique combinations from an array (using VBA)

上的帖子修改了一些代码

用法：

---将“Sheet1”更改为您的工作表名称想
输入单元格A1中的框数
在B1，C1，...等中输入名称..
调用stackBox

输入格式＆amp;输出结果为“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

在Excel中堆叠和分层框

1 个答案: