1


範囲のすべての組み合わせをそれぞれ同じ行にエクスポートするマクロの助けが必要です (水平エクスポートを意味します)。

毎回1つのセルになりたいすべての組み合わせ。

範囲内の文字列の数と文字列の組み合わせの数をいつでも変更したい (下の例では、範囲内の 4 つの文字列と組み合わせの 3 つ)

1. A B  C  D     -------------ABC --ABD--ACD--BCD
 2. E F  G  H--------------EFG---EFH--EGH--FGH
 3. I G  K  L----------------IGK----IGL---IKL---GKL

その下には、必要なものに非常に近いWebで見つけたモジュールがあります。

私はVbaマクロに非常に慣れていないため、以下のコードでは探しているものを達成できません

Private NextRow As Long

Sub Test()
Dim V() As Variant, SetSize As Integer, i As Integer

    SetSize = Cells(2, Columns.count).End(xlToLeft).Column
    ReDim V(1 To SetSize)

    For i = 1 To SetSize
        V(i) = Cells(2, i).Value
    Next i

    NextRow = 4
    CreateCombinations V, 3, 3

End Sub


Sub CreateCombinations( _
                   OriginalSet() As Variant, _
                  MinSubset As Integer, MaxSubset As Integer)

Dim SubSet() As Variant, SubSetIndex As Long
Dim SubSetCount As Integer, Bit As Integer
Dim k As Integer, hBit As Integer
Dim MaxIndex As Long

hBit = UBound(OriginalSet) - 1
ReDim SubSet(1 To UBound(OriginalSet))

    MaxIndex = 2 ^ UBound(OriginalSet) - 1
    For SubSetIndex = 1 To MaxIndex
        SubSetCount = BitCount(SubSetIndex)
        If SubSetCount >= MinSubset And SubSetCount <= MaxSubset Then
            k = 1
            For Bit = 0 To hBit
                If 2 ^ Bit And SubSetIndex Then
                    SubSet(k) = OriginalSet(Bit + 1)
                    k = k + 1
                End If
            Next Bit
            DoSomethingWith SubSet, SubSetCount
        End If
    Next SubSetIndex
End Sub


Sub DoSomethingWith(SubSet() As Variant, ItemCount As Integer)
Dim i As Integer


    For i = 1 To ItemCount
        Cells(NextRow, i) = SubSet(i)
    Next i
    NextRow = NextRow + 1
End Sub





Function BitCount(ByVal Pattern As Long) As Integer
    BitCount = 0
    While Pattern
        If Pattern And 1 Then BitCount = BitCount + 1
        Pattern = Int(Pattern / 2)
    Wend
End Function
4

1 に答える 1