问题
I am layering, stacking my options in excel. I have asked the question in a similar way, however I now want to put some more detail into it. If I have n number of boxes to stack, the possible options to stack them is 2^n-1. Let me give an example of 3 boxes and we give them the names A, B, C and D. The way they are stacked does not matter, meaning AB=BA and ABC=CAB, they count as 1 stack option. The result would be:
A, B, C, AB, BC, AC, ABC
Now I would like to create an excel file which in which I will enter the boxes letters and it gives me a list of all the possibilities for stacking. So I would provide the number of boxes and the letters. (3 boxes, A, B, C) Excel reads this in and gives me in cells the options.
Is it possible to get the options in a row underneath each other? for n number of boxes?
Is this possible? Can anyone help me with this?
Thank you in advanced!
回答1:
Some Code modified from Tony Dallimore's post on Creating a list of all possible unique combinations from an array (using VBA)
usage:
in Macro "stackBox" --- change "Sheet1" to the worksheet name you want
input the Number of boxes in cell A1
input the name in B1, C1, ... and so on ..
call stackBox
Input Format & Output result in "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
The code:
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
来源：https://stackoverflow.com/questions/12950671/stacking-and-layering-boxes-in-excel