全ての組み合わせを生成するマクロ

はじめに

全パラメータの組み合わせを生成するマクロを作ってみた。開発の現場では全ての組み合わせをテストすることはないので実用的ではないが、単にロジックを考えるのが面白かったので作ってみた。

使用方法

１．「全組み合わせ生成」マクロを実行する。

２．入力となる複数の範囲を選択する。

３．出力先となるセルを選択する。

実行結果

コード

Option Explicit

Sub 全組み合わせ生成()

    Const MB_TITLE = "全組み合わせ生成"
    Const MB_MSG_1 = "入力となる複数の範囲を選択して下さい。"
    Const MB_MSG_2 = "出力先のセルを選択して下さい。"

    '全組み合わせ生成の入力となる複数の範囲の選択
    Dim Source As Range
    Set Source = SelectRangeBox(Prompt:=MB_MSG_1, Title:=MB_TITLE)

    If Source Is Nothing Then
        Exit Sub
    End If

    '全組み合わせ生成の出力先となるセルの選択
    Dim Destination As Range
    Set Destination = SelectRangeBox(Prompt:=MB_MSG_2, Title:=MB_TITLE)

    If Destination Is Nothing Then
        Exit Sub
    End If

    '入力となる複数の範囲をRange配列に格納
    Dim Sources() As Range
    ReDim Sources(1 To Source.Areas.Count) As Range

    Dim i As Long
    For i = LBound(Sources) To UBound(Sources)
        Set Sources(i) = Source.Areas(i)
    Next

    '全組み合わせ生成の実行
    Dim Result As Range
    Set Result = GenerateAllCombinations(Destination, Sources)

    '生成された範囲を選択
    If Not Result Is Nothing Then
        Call Result.Parent.Activate
        Call Result.Select
    End If

End Sub

'===============================================================================
' 範囲選択用の入力ボックス
'-------------------------------------------------------------------------------
' [引数] Application.InputBoxの引数を参照
'-------------------------------------------------------------------------------
' [戻り値] 範囲選択した場合はRangeオブジェクト, キャンセルした場合はNothing
'===============================================================================
Private Function SelectRangeBox(Prompt As String, Optional Title, Optional Default, Optional Left, Optional Top) As Range
    On Error Resume Next
    Set SelectRangeBox = Application.InputBox(Prompt:=Prompt, Title:=Title, Default:=Default, Left:=Left, Top:=Top, Type:=8)
End Function

'===============================================================================
' 全組み合わせ生成処理のコアの部分
'-------------------------------------------------------------------------------
' [引数]
' Destination : 出力先のセル
' Sources     : 入力となる範囲の配列
' Index       : 配列のインデックス。内部で再帰呼出しするためのもの。
'-------------------------------------------------------------------------------
' [戻り値] 生成した範囲(Rangeオブジェクト)
'===============================================================================
Private Function GenerateAllCombinations(ByVal Destination As Range, Sources() As Range, Optional ByVal Index As Long = -1) As Range

    Dim DestCell As Range, SrcRow As Range, ResultRange As Range

    If Index < LBound(Sources) Then
        Index = LBound(Sources)
    ElseIf Index > UBound(Sources) Then
        Debug.Assert False
    End If

    Set DestCell = Destination.Cells(1)

    If Index = UBound(Sources) Then
        '最後の要素の場合は入力となる範囲を出力先へそのままコピーする
        With Sources(Index).Areas(1)
            Call .Copy(DestCell)
            Set ResultRange = DestCell.Resize(.Rows.Count, .Columns.Count)
        End With
    Else
        '最後の要素以外は入力となる範囲を行単位にコピーする
        For Each SrcRow In Sources(Index).Areas(1).Rows
            Set ResultRange = GenerateAllCombinations(DestCell.Offset(0, SrcRow.Columns.Count), Sources, Index + 1)
            Call SrcRow.Copy(DestCell.Resize(ResultRange.Rows.Count, SrcRow.Columns.Count))
            Set DestCell = DestCell.Offset(ResultRange.Rows.Count, 0)
        Next
        Set ResultRange = Application.Range(Destination.Cells(1), ResultRange)
    End If

    Set GenerateAllCombinations = ResultRange

End Function