数値が被らない全ての組み合わせを作成し、ソート後に表示：Excel VBA

複数の数値から、かぶらない全ての組み合わせを作成します。その後ソートし昇順で表示します。

ここでは強引に総当たりで作成しているので、無駄が多く実行に時間が掛かります。

実行結果を完全にチェックしていませんので注意してください。

ソート（並べ替え）については「配列のソート」を参照してください。

かぶらない全ての組み合わせを作成する

作成した実行シートです。
B列に組み合わせの元になる数値を入力します。
これはいくつでも構いませんが、多いいと処理時間が掛かります。
組み合わせは5個にしています。これは固定です。変更するにはVBAの修正が必要です。


全ての組み合わせを作成するVBAです。
ループを使った、総当たりの強引なVBAになっています。


・5個の組み合わせを作るので、5個のForループを使用しています。
・組み合わせに同じ数値がないかチェックします。あればbFlagがTRUEになります。
・これまで作成した組み合わせに同じものがないかチェックします。あればbFlagがTRUEになります。
・bFlagがFALSEの場合、表示します。

Sub MyAll()
    Dim lr As Long
    Dim lrck As Long
    Dim lrmax As Long
    Dim i As Long
    Dim j As Long
    Dim k As Long
    Dim bflag As Boolean
    Dim n(5) As Long
    Dim i1 As Long
    Dim i2 As Long
    Dim i3 As Long
    Dim i4 As Long
    Dim i5 As Long
    
    Range("D2:H10000").Clear
    lr = 2
    lrmax = Range("B2").End(xlDown).Row
    For i1 = 2 To lrmax
        For i2 = 2 To lrmax
                For i3 = 2 To lrmax
                        For i4 = 2 To lrmax
                            For i5 = 2 To lrmax
                                
                                n(1) = Cells(i1, 2)
                                n(2) = Cells(i2, 2)
                                n(3) = Cells(i3, 2)
                                n(4) = Cells(i4, 2)
                                n(5) = Cells(i5, 2)
                                
                                bflag = False
                                For i = 1 To 5
                                    For j = 2 To 5
                                        If i <> j And n(i) = n(j) Then
                                            bflag = True
                                        End If
                                    Next
                                Next
                                
                                If bflag = False Then
                                    lrck = 2
                                    Do
                                        If Cells(lrck, 4) = "" Then
                                            Exit Do
                                        End If
                                        
                                        k = 0
                                        For i = 1 To 5
                                            For j = 1 To 5
                                                If n(i) = Cells(lrck, j + 3) Then
                                                    k = k + 1
                                                End If
                                            Next
                                        Next
                                        
                                        If k = 5 Then
                                            bflag = True
                                            Exit Do
                                        End If
                                        
                                        lrck = lrck + 1
                                    Loop
                                End If
                                
                                If bflag = False Then
                                    Cells(lr, 4) = n(1)
                                    Cells(lr, 5) = n(2)
                                    Cells(lr, 6) = n(3)
                                    Cells(lr, 7) = n(4)
                                    Cells(lr, 8) = n(5)
                                    lr = lr + 1
                                End If
                            Next i5
                        Next i4
                Next i3
        Next i2
    Next i1
    
End Sub

実行結果です。
元の数値の、全ての組み合わせが表示されています。

数値の並び順をソートし見やすくする

上の実行結果では数値の並びがバラバラなので見にくいのでソートします。
配列の数値をソートするVBAです。


以前掲載した文字列の配列のソートを、数値型に変更しています。

Private Sub ExSort(sary() As Long)
     Dim i As Long
     Dim j As Long
     Dim h As Long
     Dim temp As String

     h = LBound(sary())
     For i = 1 To UBound(sary()) - 1
          h = h * 3 + 1
     Next

     Do
         h = h / 3
         For i = h + LBound(sary()) To UBound(sary())
             temp = sary(i)
             j = i
            Do While sary(j - h) > temp
                 sary(j) = sary(j - h)
                 j = j - h
                 If j < h Then
                     Exit Do
                 End If
             Loop
             sary(j) = temp
         Next
     Loop Until h = LBound(sary())

 End Sub

ソートの呼び出しを追加したVBAです。


・ExSort n を追加しています。

                                If bflag = False Then
                                    ExSort n
                                    
                                    Cells(lr, 4) = n(1)
                                    Cells(lr, 5) = n(2)
                                    Cells(lr, 6) = n(3)
                                    Cells(lr, 7) = n(4)
                                    Cells(lr, 8) = n(5)
                                    lr = lr + 1
                                End If

ソートした実行結果です。