再びトーナメント表作成 ⑧ 第一段階完成 - Infomentのブログ～Excel VBA奮闘記～

先日から、トーナメント表作成の仕組みを焼き直ししている。
infoment.hatenablog.com
今回も、前回の続きから。

前回の結果を踏まえ、最終的にこの形に落ち着いた。

Option Explicit

Public PlayerRange As Range
Public PlayerDict As Object
Public InversFlag As Boolean
Public StartNumber As Long
Dim Wf As WorksheetFunction
Dim NetPalyerNumber As Long
Dim TournamentSize As Long
Dim PlayerCount As Long

' 名前のセル罫線要否。
Public BordersAroundName As Boolean
' 勝ち残りの名前セル要否。
Public IntermediateName As Boolean

Private Sub Class_Initialize()
    Set Wf = WorksheetFunction
End Sub

Public Sub init(Optional player_range As Range, _
                Optional invers_flag As Boolean = False, _
                Optional start_number As Long = 1, _
                Optional borders_around_name As Boolean = False, _
                Optional intermediate_name As Boolean = False)
    
    Dim arr As Variant
    Dim i As Long
        If Not player_range Is Nothing Then
            Set PlayerRange = player_range
        Else
            Set PlayerRange = Selection
        End If
        InversFlag = invers_flag
    
    Set PlayerDict = CreateObject("Scripting.Dictionary")
    Dim r As Range
        For Each r In PlayerRange
            If r.Value <> vbNullString Then
                NetPalyerNumber = NetPalyerNumber + 1
                PlayerDict(NetPalyerNumber) = r.Value
            End If
        Next

        ' 一回戦の人の配置を、前大会の何位からランダムに入れ替えるか。
        StartNumber = start_number

        ' 選手の数から求めるトーナメントサイズ（決勝までの段数）。
        TournamentSize = Wf.Ceiling_Math(Wf.Log10(NetPalyerNumber), Wf.Log10(2)) / Wf.Log10(2)

        ' 一回戦の人数。
        PlayerCount = 2 ^ TournamentSize
        
        ' 名前周辺の罫線要否。
        BordersAroundName = borders_around_name
        
        ' 勝ち上がり選手名の箱要否。
        IntermediateName = intermediate_name

End Sub

Private Property Get TournamentOrderArray() As Variant
    
    ' 作業用配列。最終的に戻り値となる。
    Static arr As Variant
    If Not IsEmpty(arr) Then
        TournamentOrderArray = arr
        Exit Property
    End If
    
    ReDim arr(1 To 1)
    ' 初期値。選手が一人のとき。
        arr(1) = 1
        If PlayerCount = 1 Then
            TournamentOrderArray = arr
            Exit Property
        End If
    
    Dim i As Long
    Dim j As Long
    
    ' 選手の数に併せて大きくなるトーナメントの仮格納用配列。
    Dim TempArray As Variant
        For i = 1 To TournamentSize
            ReDim TempArray(1 To UBound(arr) * 2)
            For j = 1 To UBound(arr)
                ' 元の配列内の数値を、上から奇数で、下から偶数でセット。
                TempArray(j) = arr(j) * 2 - 1
                TempArray(UBound(TempArray) + 1 - j) = arr(j) * 2
            Next
            arr = TempArray
        Next
        
        ' 上位半数の相手を改めてセット。
        ' 例えば32人のトーナメントでは、1と32が、2と31が、3と30が・・・nと33-nが
        ' ペアになるようにする。※優先的に前回上位者を一回戦シードとするため。
        For i = 1 To PlayerCount
            If arr(i) > PlayerCount / 2 Then
                ' ４人一組で評価するとき、２番目は１番目と、３番目は４番目と
                ' ペアになることから、４で割った余りで処理を変更する。
                Select Case i Mod 4
                    Case 2: arr(i) = PlayerCount - arr(i - 1) + 1
                    Case 3: arr(i) = PlayerCount - arr(i + 1) + 1
                End Select
            End If
        Next
        TempArray = arr
        
        ' 配列の最後を１位にしたい場合用。配列の順序をひっくり返す。
        If InversFlag Then
            For i = 1 To UBound(arr)
                arr(i) = TempArray(UBound(TempArray) - i + 1)
            Next
        End If
        
        TournamentOrderArray = arr

End Property

Private Property Get RandomSortDict() As Object

    Static Dict As Object
        If Not Dict Is Nothing Then
            Set RandomSortDict = Dict
            Exit Property
        End If

    ' 作業用配列。
    Dim TempArray As Variant
    ReDim TempArray(1 To NetPalyerNumber)
    ' 戻り値用配列。
    Dim arr As Variant
    ReDim arr(1 To NetPalyerNumber)

    Dim i As Long
        For i = 1 To NetPalyerNumber
            ' ソートしない範囲。
            If i < StartNumber Then
                TempArray(i) = i
            
            ' ソート範囲。iMax以上の桁でソートする。
            ' このときtotalの桁数範囲には、元の数字が保存されている。
            Else
                TempArray(i) = CLng(WorksheetFunction.RandBetween(1, 100) * _
                              (10 ^ Len(CStr(PlayerCount))) + i)
            End If
        Next

        ' 配列ソート。
        TempArray = SortArray(TempArray)
        
        ' 保存された元の数字を取り出す。
        ' SortArray関数を使用すると、配列が０始まりになるので注意。
        For i = NetPalyerNumber To 1 Step -1
            arr(i) = Right(TempArray(i - 1), CLng(Len(CStr(NetPalyerNumber)))) * 1
        Next

    Set Dict = CreateObject("Scripting.Dictionary")
        For i = 1 To NetPalyerNumber
            Dict(i) = arr(i)
        Next
        
        If NetPalyerNumber < PlayerCount Then
            For i = NetPalyerNumber + 1 To PlayerCount
                Dict(i) = i
            Next
        End If
        
    Set RandomSortDict = Dict

End Property

Public Function SortArray(ByVal source_array As Variant, _
                       Optional sort_order As Excel.XlSortOrder = xlAscending) As Variant
                       
    Dim aryList As Object
    Set aryList = CreateObject("System.Collections.ArrayList")
    Dim s As Variant
    
        For Each s In source_array
            Call aryList.Add(s)
        Next
    
        Select Case sort_order
            Case xlAscending
                ' 昇順でソート。
                Call aryList.Sort
            Case xlDescending
                ' 昇順でソートののち、降順へ反転。
                Call aryList.Sort
                Call aryList.Reverse
        End Select
    
        SortArray = aryList.ToArray
        
End Function

Public Property Get TournamentSortedOrderArray()

    Dim i As Long
    Dim arr() As Variant
    ReDim arr(1 To PlayerCount)
        For i = 1 To PlayerCount
            arr(i) = PlayerDict(RandomSortDict(TournamentOrderArray(i)))
        Next
        TournamentSortedOrderArray = arr
        
End Property

Public Sub CreateTournament()

    Sheets.Add After:=Sheets(Sheets.Count)
       
    Dim i As Long
    Dim j As Long
    
        ' １回戦～準決勝戦まで。
        For j = 1 To TournamentSize
            ' ｊ回戦の一人一人について。
            For i = 1 To (2 ^ TournamentSize) / (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 ^ TournamentSize, 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 TournamentSize
            For i = 1 To 2 ^ (TournamentSize - j)
                Cells((2 ^ (j + 1)) * i - (3 * 2 ^ (j - 1) - 1), 3 * j - 1).Resize(2 ^ j).Borders(xlEdgeRight).Weight = xlThin
            Next
        Next
        
        ' 名前のセット
    Dim arr As Variant
        arr = TournamentSortedOrderArray
        
        For i = 1 To UBound(arr)
            Cells(i * 2 - 1, 1) = arr(i)
        Next
        
    ' シードを確認。
    Dim PlayerName(2) As String
        If TournamentSize >= 2 Then
            For i = 1 To 2 ^ TournamentSize / 2
            
                ' 一回戦の対戦同士、セル４つを一組で考える。
                With Cells(4 * i - 3, 1)
                    
                    ' それぞれのセット順を配列に格納。
                    PlayerName(0) = .Item(1) & .Item(3)
                    PlayerName(1) = .Item(1)
                    PlayerName(2) = .Item(3)
                    
                    ' 両方ともに空白はあり得ない（その場合、トーナメントの山が一つ小さくなる）。
                    ' したがって、両者順位の積が０ならば、それは一回戦が不戦勝を意味する（＝シード）。
                    If PlayerName(1) = vbNullString Or PlayerName(2) = vbNullString Then
                        
                        ' セルの結合しなおし。および、罫線の引き直し。
                        With .Resize(4)
                            .UnMerge
                            .Resize(, 2).Borders.LineStyle = xlNone
                            .Value = vbNullString
                            .Item(2) = PlayerName(0)
                            .Borders.LineStyle = xlNone
                            .Item(2).Resize(2).Merge
                            .Item(2).Resize(2).Borders.Weight = xlThin
                            .Item(2).Resize(2, 2).Borders(xlInsideHorizontal).Weight = xlThin
                        End With
                    End If
                End With
            Next
        End If

End Sub

Private Sub AdjustFormat()
    Dim i As Long
 
        ' トーナメント表の名前以外の幅を調整。
        For i = 0 To TournamentSize
            Columns("B:C").Offset(, 3 * i).ColumnWidth = 3
        Next

        ' 名前セルの罫線設定。
        If Not BordersAroundName Then
            Columns(2).Borders(xlEdgeLeft).LineStyle = xlNone
            For i = 0 To TournamentSize
                Columns(3 * i + 1).Borders.LineStyle = xlNone
            Next
        End If

        ' 勝ち残り名前セルの設定。
        If Not IntermediateName Then
            For i = 0 To TournamentSize - 2
                Cells(1, i + 3).Resize(, 2).EntireColumn.Delete
            Next
        End If
        
        Columns(1).EntireColumn.AutoFit
        
        ' 空白セルの高さ設定。
        For i = 1 To ActiveSheet.UsedRange.Rows.Count
            If Cells(i, 1).MergeCells = False Then
                Cells(i, 1).RowHeight = Cells(i, 1).RowHeight / 4
            End If
        Next
End Sub

Private Sub Class_Terminate()
    Call AdjustFormat
End Sub

ここまで作りこんでおくと、実際のトーナメント作成はこれだけで済む。

Sub Test()
    With New VBAProject.Tournament
        ' 名簿の範囲指定。
        .init Sheets("sheet1").ListObjects(1).ListColumns(2).DataBodyRange
        ' トーナメント作成。
        .CreateTournament
    End With
End Sub