昨日はリストの上位にいる選手が、優先的にシード選手になるようにしてみた。
infoment.hatenablog.com
今日は、本シリーズ最終回。一応完成（のつもりです）。
といっても、ほとんどは昨日の内にできている。今日はいつものごとく、作成したそれをクラスモジュールに移植してみた。
※詳細はコメント参照。
クラスモジュール（Tournament）
Option Explicit Public Enum Necessity xlYes xlNo End Enum ' リスト情報が記された範囲。 Public ListRange As Range ' 名前のセル罫線要否。 Public BordersAroundName ' 勝ち残りの名前セル要否。 Public IntermediateName Private Sub Class_Initialize() Call init Application.ScreenUpdating = False End Sub Public Sub init(Optional borders_around_name As Necessity = xlNo, _ Optional intermediate_name As Necessity = xlNo) BordersAroundName = borders_around_name IntermediateName = intermediate_name End Sub Private Property Get ListArray() As Variant ListArray = ListRange.Columns(1).Value End Property Private Property Get TournamentHeight() As Long TournamentHeight = WorksheetFunction.RoundUp(WorksheetFunction.Log(UBound(ListArray), 2), 0) End Property Public Sub CreateTournament() Sheets.Add After:=Sheets(Sheets.Count) Dim arr As Variant arr = ListArray Dim iMax As Long iMax = TournamentHeight 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) = i Next End If ' 対戦相手の組み合わせで、シードを確認。 Dim Player(1 To 2) As Long If iMax >= 2 Then For i = 1 To 2 ^ iMax / 2 ' 一回戦の対戦同士、セル４つを一組で考える。 With Cells(4 * i - 3, 1) ' それぞれのセット順を配列に格納。 ' この時点で空白の場合、順位には０が入る。 Player(1) = .Item(1) Player(2) = .Item(3) ' 両方ともに空白はあり得ない（その場合、トーナメントの山が一つ小さくなる）。 ' したがって、両者順位の積が０ならば、それは一回戦が不戦勝を意味する（＝シード）。 If Player(1) * Player(2) = 0 Then ' セルの結合しなおし。および、罫線の引き直し。 With .Resize(4) .UnMerge .Resize(, 2).Borders.LineStyle = xlNone .Value = vbNullString .Item(2) = WorksheetFunction.Max(Player) .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 ' 数字を名前に置き換え。 Dim r As Range For Each r In Cells(1, 1).Resize(2 ^ (iMax + 1)) If r <> vbNullString Then r = arr(r) End If Next End Sub ' 配列内のランダム並べ替え。 Private 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 TempArray() As Variant ReDim TempArray(LBound(source_array) To UBound(source_array)) For i = LBound(TempArray) To UBound(TempArray) TempArray(i) = Dict(i) Next RandomSort = TempArray End Function Private Sub AdjustFormat() Dim i As Long ' トーナメント表の名前以外の幅を調整。 For i = 0 To TournamentHeight Columns("B:C").Offset(, 3 * i).ColumnWidth = 3 Next ' 名前セルの罫線設定。 If BordersAroundName = Necessity.xlNo Then Columns(2).Borders(xlEdgeLeft).LineStyle = xlNone For i = 0 To TournamentHeight Columns(3 * i + 1).Borders.LineStyle = xlNone Next End If ' 勝ち残り名前セルの設定。 If IntermediateName = Necessity.xlNo Then For i = 0 To TournamentHeight - 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 ActiveWindow.DisplayGridlines = False Application.ScreenUpdating = True End Sub
例によって例のごとく、標準モジュールはスッキリした。今回は一人ずつ参加人数を増やすことで、トーナメントがどのように作成されるか見てみよう。
Sub Sample() Dim i As Long For i = 2 To 12 With New Tournament Set .ListRange = Sheet1.Range("B2").Resize(i) .CreateTournament End With Range("D1").Select Application.Wait [Now()+"00:00:01"] Next End Sub
結果はコチラ。
それにしても今回は、難しかった。でも面白かったので、良しとします。
参考まで。