トーナメント作成 ⑤ 指定番数以降をランダムに並べ替え

昨日は、トーナメント表に、如何にして選手を並べるかに挑戦した。
infoment.hatenablog.com

今日は、昨日の続きに挑戦する。

まず８人を一塊として考えている関係上、８人以下の場合は一般式に充てられないような作りにしてしまった。

そこで２～８人の場合は一般式ではなく決め打ちで、入力するセルを設定することにした。

２人の場合。

４人の場合。

８人の場合。

昨日は各セルに、選手の名前を入力する順序を表示したが、今回は、入力順のセルそのものを myRng() にセットしている。

更に、全員を均等に配置していくと、最下位の人は毎回必ず一位の人と対戦することになる。これでは、最下位の人はいつまで経っても、一回戦突破は望めない。
そこで、シード選手以下の選手は、並びをランダムに並び替えることとした。

' 配列内のランダム並べ替え。
Function RandomSort(ByVal source_array As Variant, _
           Optional ByVal start_index As Long = -1, _
           Optional ByVal end_index As Long = -1) As Variant

        ' この関数は、一次元配列にのみ適用可。
        ' 従って、二次元要素に関する情報を求め、それがエラーなく
        ' 取得できたのであれば、この配列は一次元配列ではないと
        ' 判断できる。空配列を戻り値として、即終了。
        On Error Resume Next
        Debug.Print UBound(source_array, 2)
        If Err.Number = 0 Then
            RandomSort = Array()
            Exit Function
        End If

        ' 指定開始位置および指定終了位置が「-1」の場合、つまり
        ' 無指定の場合は、それぞれ先端および終端とする。
        If start_index = -1 Then start_index = LBound(source_array)
        If end_index = -1 Then end_index = UBound(source_array)
    
    ' 並べ替え用辞書（連想配列）。
    ' この関数が丸々コピーされることを想定し、参照設定不要とするため
    ' レイト・バインディングとしている。
    Dim Dict As Object
    Set Dict = CreateObject("Scripting.Dictionary")
    
    
    Dim i As Long
    Dim Index As Long
    
        ' 指定開始位置が先端でないならば、先端から指定開始位置までを
        ' そのままの順序で辞書に登録する。
        If start_index <> LBound(source_array) Then
            For i = LBound(source_array) To start_index - 1
                Dict(i) = source_array(i)
            Next
        End If
        
            ' 指定開始位置から指定終了位置まで、並び替えて辞書に登録する。
            For i = start_index To end_index
                Do
                    Index = WorksheetFunction.RandBetween(start_index, end_index)
                    
                    ' 辞書に対しキーが重複登録できない仕様を利用して、ランダムで
                    ' 未登録の数字を求める。
                    If Dict.Exists(Index) = False Then Exit Do
                Loop
                Dict(Index) = source_array(i)
            Next
        
        ' 指定終了位置が終端でないならば、指定終了位置よりも後から終端までを
        ' そのままの順序で辞書に登録する。
        If end_index <> UBound(source_array) Then
            For i = end_index + 1 To UBound(source_array)
                Dict(i) = source_array(i)
            Next
        End If
    
    ' 辞書の内容を配列に移植。
    Dim arr() As Variant
    ReDim arr(LBound(source_array) To UBound(source_array))
        For i = LBound(arr) To UBound(arr)
            arr(i) = Dict(i)
        Next
        
        RandomSort = arr
End Function

これらを踏まえ、昨日のものを改修したのがこちら。

Sub Sample()

    Cells.Clear
    
    ' トーナメント参加者リスト。
    ' ※シート１のなんちゃって個人情報を参照。
    ' ※今回は、50人決め打ち。
    Dim arr() As Variant
        arr = Sheet1.Range("B2:B10").Value
    
    ' 参加者人数から、トーナメントが何回戦まで必要かを求める。
    Dim iMax As Long
        iMax = WorksheetFunction.RoundUp(WorksheetFunction.Log(UBound(arr), 2), 0)
    Dim i As Long
    Dim j As Long
    
        ' １回戦～準決勝戦まで。
        For j = 1 To iMax
            ' ｊ回戦の一人一人について。
            For i = 1 To (2 ^ iMax) / (2 ^ (j - 1))
                With Cells((2 * i - 1) * 2 ^ (j - 1), 3 * j - 2)
                    Select Case j
                        ' 横の罫線だけ、先に描画しておく。
                        ' ※セル結合により、人名入力セル内は罫線が無くなる。
                        Case 1
                            .Resize(, 2).Borders(xlEdgeBottom).Weight = xlThin
                        Case Else
                            .Resize(, 3).Offset(, -1).Borders(xlEdgeBottom).Weight = xlThin
                    End Select
                    .Resize(2).Merge
                    .Resize(2).Borders.Weight = xlThin
                End With
            Next
        Next
    
        ' 決勝戦。
        With Cells(2 ^ iMax, 3 * j - 2)
            .Resize(, 2).Offset(, -1).Borders(xlEdgeBottom).Weight = xlThin
            .Resize(2).Merge
            .Resize(2).Borders.Weight = xlThin
        End With
        
        ' 縦の線。
        For j = 1 To iMax
            For i = 1 To 2 ^ (iMax - j)
                Cells((2 ^ (j + 1)) * i - (3 * 2 ^ (j - 1) - 1), 3 * j - 1).Resize(2 ^ j).Borders(xlEdgeRight).Weight = xlThin
            Next
        Next
        
        
        ' 境界線のセット。
        If iMax >= 4 Then
            Dim SetArrayBoundary() As Variant
            ReDim SetArrayBoundary(1 To 2 ^ (iMax - 2) - 1)
                For i = 1 To UBound(SetArrayBoundary)
                    Select Case i
                        Case 1
                            SetArrayBoundary(i) = (2 ^ iMax) / 2
                        Case Is <= 3
                            SetArrayBoundary(i) = (2 ^ iMax) / 4 * (2 * i - 3)
                        Case Is <= 7
                            SetArrayBoundary(i) = (2 ^ iMax) / 8 * (2 * i - 7)
                        Case Is <= 15
                            SetArrayBoundary(i) = (2 ^ iMax) / 16 * (2 * i - 15)
                        Case Is <= 31
                            SetArrayBoundary(i) = (2 ^ iMax) / 32 * (2 * i - 31)
                    End Select
                Next
        End If
        
    Dim myRng() As Range
    ReDim myRng(1 To 2 ^ iMax)
    Dim Counter As Long: Counter = 3
        
        ' 一番上が前回１位。
        Set myRng(1) = Cells(1, 1)
        
        ' 前回１位の相手は、一番最後の人。これにより、
        ' 前回１位のシード優先順位は１位となる。
        Set myRng(2 ^ iMax) = Cells(3, 1)
        ' 前回２位の相手。考え方は１位と同様。
        Set myRng(2 ^ iMax - 1) = Cells(2 * (2 ^ iMax) - 3, 1)
        
        ' 一番下が前回２位。
        Set myRng(2) = Cells(2 * (2 ^ iMax) - 1, 1)
        
        ' ３位以降の順序をセット。
        Select Case iMax
            ' １回戦が決勝の場合。２人しかいないので、処置不要。
            Case 1
            
            ' ２回戦が決勝の場合。４人しかいないので、上記でセット済み。
            Case 2

            ' ３回戦が決勝に場合。
            Case 3
                Set myRng(3) = Cells(7, 1)
                Set myRng(4) = Cells(9, 1)
                Set myRng(5) = Cells(11, 1)
                Set myRng(6) = Cells(5, 1)
                Set myRng(7) = Cells(13, 1)
                Set myRng(8) = Cells(3, 1)
                
            ' それ以外の場合。
            ' ４人一塊でセットしていく。
            ' 先ほど求めた「境界線」を背中合わせに高位から順に配置し、その相手が下位から
            ' 順に配置されるようにする。この法則を守れば、対戦相手とのセット順序の和は、
            ' 必ず２のｎ乗＋１（９，１７，３３，６５・・・）になる。
            Case Else
                For i = 1 To UBound(SetArrayBoundary)
                    Set myRng(2 ^ iMax + 1 - Counter) = Cells(2 * SetArrayBoundary(i) - 3, 1)
                    Set myRng(Counter) = Cells(2 * SetArrayBoundary(i) - 1, 1)
                    Set myRng(Counter + 1) = Cells(2 * SetArrayBoundary(i) + 1, 1)
                    Set myRng(2 ^ iMax - Counter) = Cells(2 * SetArrayBoundary(i) + 3, 1)
    
                    Counter = Counter + 2
                Next
        End Select
        
        ' 範囲指定で作成した配列なので、１列でも２次元配列になっている。
        ' 縦横の入れ替えで、これを一次元配列に変換する。
        arr = WorksheetFunction.Transpose(arr)
        
        ' シード選手以下の順位を、ランダムに並べ替える。これにより、最下位の選手が常に
        ' １位の選手と組み合わせになることが無くなる。
        arr = RandomSort(arr, 2 ^ (iMax - 2) + 1)
        
        ' 配列の並び替えが失敗した場合、空配列が戻り値となる。
        ' 空配列のUBoundは－１であるため、以下の条件分岐となる。
        If UBound(arr) <> -1 Then
            ' 各選手を、順番通りにセット。
            For i = 1 To UBound(arr)
                myRng(i) = arr(i)
            Next
        End If
End Sub

早速、なんちゃって個人情報で作成してみよう。結果はこちら。
※分かり易さのため、前回の順位を先頭に付している。

意図したとおり、シード選手は一回戦不戦勝になっている。

やっと、大きなヤマを越えたかな。明日に続きます。

参考まで。