excel中的堆叠和分层框_Excel_Vba_Combinatorics

excel中的堆叠和分层框

excel vba

excel中的堆叠和分层框,excel,vba,combinatorics,Excel,Vba,Combinatorics,我正在分层，在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

我正在分层，在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个盒子

这可能吗？有人能帮我吗

提前谢谢你

根据Tony Dallimore在

用法：

在宏“stackBox”--将“Sheet1”更改为您需要的工作表名称想要

在单元格A1中输入框数

在B1、C1、…中输入名称。。。等等

呼叫stackBox

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

守则：

 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

函数stackBox（）
将ws设置为工作表
宽度与长度相同
低矮如长
暗箱一样长
Dim optionsA（）作为变量
Dim results（）作为变量
作为字符串的Dim str
作为变量的Dim输出阵列
我和我一样长，我和我一样长
设置ws=工作表（“表1”）
与ws
'清除上次的输出
高度=.Cells（.Rows.Count，1）.End（xlUp）.row
如果高度>1，则
.Range（.Cells（2,1），.Cells（height，1））.ClearContents
如果结束
numobox=.Cells（1，1）.Value
宽度=.Cells（1，.Columns.Count）.End（xlToLeft）.Column
如果宽度小于2，则
MsgBox“错误：没有项目，请在B1、C1等单元格中填写您的项目”
退出功能
如果结束
重拨选项A（0至宽度-2）
对于i=0到宽度-2
选项A（i）=.单元格（1，i+2）.值
接下来我
生成组合选项A、结果、数字框
'仅将结果复制到工作表一次
ReDim输出阵列（1到UBound（结果，1）-LBound（结果，1）+1，1到1）
计数=0
对于i=LBound（结果，1）到UBound（结果，1）
如果不是空的（结果（i）），则
'rowNum=rowNum+1
str=“”
对于j=LBound（结果（i），1）到UBound（结果（i），1）
str=str和结果（i）（j）
下一个j
计数=计数+1
输出阵列（计数，1）=str
'.Cells（rowNum，1）.Value=str
如果结束
接下来我
.Range（.Cells（2,1），.Cells（UBound（outputArray，1）+1,1））。Value=outputArray
以
端函数
子代组合（ByRef AllFields（）作为变量_
ByRef Result（）作为变量，ByVal numobox作为变量）
Dim InxResultCrnt为整数
Dim INX字段为整数
Dim InxResult为整数
作为整数的Dim i
作为整数的Dim NumFields
整数形式的Dim Powers（）
Dim ResultCrnt（）作为字符串
NumFields=UBound（所有字段）-LBound（所有字段）+1
重拨结果（0到2^NumFields-2）'每个组合一个条目
ReDim为（0到NumFields-1）“每个字段名添加一个条目”
'生成用于从InxResult提取位的功率
对于InxField=0到NumFields-1
功率（InxField）=2^InxField
下一个
对于InxResult=0到2^NumFields-2
'将ResultCrnt大小设置为每个组合的最大字段数
'在ResultCrnt中构建此循环的组合
ReDim ResultCrnt（0到NumFields-1）
InxResultCrnt=-1
对于InxField=0到NumFields-1
如果（（InxResult+1）和幂（InxField））为0，则
'此组合中需要此字段
InxResultCrnt=InxResultCrnt+1
ResultCrnt（InxResultCrnt）=所有字段（InxField）
如果结束
下一个
如果InxResultCrnt=0，则
调试。打印“测试”
如果结束
"这里还有一个逻辑
如果InxResultCrnt>=numobox，则
结果（InxResult）=空
其他的
'放弃未使用的尾随项
ReDim保留结果RNT（0到INXResultRNT）
'将此循环的组合存储在返回数组中
结果（InxResult）=ResultCrnt
如果结束
下一个
端接头

我今晚给你回电话。我刚刚意识到，如果我要检查16种不同类型的框，excel没有足够的行。所以我想当它被填满的时候，我必须试着把它移到右边。我只是想补充一下这个问题。宏是否可以在粘贴前选中框组合。比如读盒子的高度和重量，这样当它堆叠的时候，它也会粘贴这个？当它超过一定的高度和重量时，它就不需要麻烦了。您已经输入了Thx。如果您使用的是Excel 2003或更低版本，那么您将没有足够的行来输出所有组合。我们可以把它输出到第二，第三，。。只要结果不大于65536行乘以256列=2^24，列就可以继续。第二个和第三个问题应该可以，当然这是可能的。你可以在事后处理。太好了，让我们继续几个。A、 B，C，D，E，F，G，H，I，J。如果你能帮忙的话，我会再问一个关于检查身高和体重的问题。感谢阿加尼能帮助我，明天如果我把盒子的数量设为3，我也会得到ABCDE的盒子组合。。。。我无论如何都不需要这个变量。我只需要知道所有可能的组合。请确保您使用的是最新版本的代码：Pthx，

 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