소개

사용방법

코드

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