再びトーナメント表作成 ⑤ 人を配置してみる - Infomentのブログ～Excel VBA奮闘記～

昨日は、トーナメント表作成時に全大会の上位入賞者を良い感じに
分散する関数における「考慮漏れ」の改修について紹介した。
infoment.hatenablog.com
今日は、実際に人の名前をトーナメント表にセットしてみよう。

今日までに作成した仕組みは、以下のとおり。

選手数を引数とし、トーナメント表のサイズを計算したうえで、前大会の上位入賞者同士が初戦で当たらないよう組合せを分散する関数。
１からｎまでの自然数について、任意の数以降をランダムに並べ替える関数。

これを組み合わせて、なんちゃって個人情報から参戦した30名の選手でトーナメント表を作成してみた。

なお、今回の作成に当たっては、上記「1.」の内容を収めた辞書を作成している。

Function GetRandomSortDict(total As Long, Optional start_number As Long = 1) As Object
    Dim Dict As Object
    Set Dict = CreateObject("Scripting.Dictionary")
    Dim arr As Variant
        arr = GetRandomSortArray(total, start_number)
    Dim i As Long
        For i = 1 To total
            Dict(i) = arr(i)
        Next
        
    Set GetRandomSortDict = Dict
End Function

ただしこの辞書は、後ほど消滅する（他の関数に統合される）可能性が高い。
ということで、テストしてみた。今回は30名で人数固定しているが、後ほど
一般化する予定だ。

Sub Test()

    Dim Dict_Tournament As Scripting.Dictionary
    Set Dict_Tournament = New Scripting.Dictionary
    Dim Tb As ListObject
    Set Tb = ActiveSheet.ListObjects(1)
    Dim i As Long
        For i = 1 To 30
            With Tb.DataBodyRange
                Dict_Tournament(i) = Format(.Cells(i, 1), "00：") & _
                                     .Cells(i, 2) & _
                                     "（" & .Cells(i, 3) & "）"
            End With
        Next
        
    Dim arr As Variant
        arr = GetTournamentOrderArray(30, True)
    
    Dim Dict_Player As Scripting.Dictionary
    Set Dict_Player = GetRandomSortDict(30, 9)
        For i = 31 To 32
            Dict_Player(i) = i
        Next
    
        For i = 1 To 32
            If Dict_Player.Exists(arr(i)) Then
                arr(i) = Format(arr(i), "00_") & Dict_Tournament(Dict_Player(arr(i)))
            Else
                arr(i) = Format(arr(i), "00_")
            End If
        Next
    
        Range("E1").Resize(32) = WorksheetFunction.Transpose(arr)

End Sub