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

配列からすべての可能な一意の組み合わせのリストを作成する (VBA を使用)に関する Tony Dallimore の投稿から変更された一部のコード

利用方法：

  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 に答える