Help us understand the problem. What is going on with this article?

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

More than 1 year has passed since last update.

はじめに

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

使用方法

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

image.png

2.入力となる複数の範囲を選択する。

image.png

3.出力先となるセルを選択する。

image.png

実行結果

image.png

コード

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

Why do not you register as a user and use Qiita more conveniently?
  1. We will deliver articles that match you
    By following users and tags, you can catch up information on technical fields that you are interested in as a whole
  2. you can read useful information later efficiently
    By "stocking" the articles you like, you can search right away
Comments
Sign up for free and join this conversation.
If you already have a Qiita account
Why do not you register as a user and use Qiita more conveniently?
You need to log in to use this function. Qiita can be used more conveniently after logging in.
You seem to be reading articles frequently this month. Qiita can be used more conveniently after logging in.
  1. We will deliver articles that match you
    By following users and tags, you can catch up information on technical fields that you are interested in as a whole
  2. you can read useful information later efficiently
    By "stocking" the articles you like, you can search right away