再びトーナメント表作成 ⑧ 第一段階完成
先日から、トーナメント表作成の仕組みを焼き直ししている。
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
前回との大きな違いはやはり、人数の上限が無くなったことか。
5000人で試してみたところ、問題なく作成できた。
やれやれ、やっと形になった。と思ったら、先生から新たなリクエストが。
- 同じ道場の子は、１回戦で当たらないようにしたい。
- 形と組手で、同じ対戦相手と当たらないようにしたい。
トライしましょう。
ということで、今のところ第一弾完成。次回は、１回戦で同門対決にならない
仕掛けに挑戦です。
参考まで。
再びトーナメント表作成 ⑦ 式の一般化
前回からかなり時間が空いてしまったが、トーナメント表作成の仕組みを焼き直ししている。
infoment.hatenablog.com
今回は、ずっと以前に作成したクラスモジュールの一般化について。
なぜ前回から時間が空いてしまったか。理由は幾つかあるが、その一つとして
「ずっと以前に作成したクラスモジュールの一般化にてこずった」というのが
ある。前回作成したトーナメントは、実は32人までにしか対応していない。
そこで今回は、まず↓の部分を一般化することにした。
抜き出してみると、こんな感じだ。
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
Select Case で、小刻みに範囲を変化させている。これを一つに統合することを
試みたのだが、集中して考える時間がなかなか取れず、今に至った訳で。まず、
↓ の部分に変数 ｉ が登場しない。
SetArrayBoundary(i) = (2 ^ iMax) / 2
この部分は切り分けるか？と考えては、思考停止の繰り返し。しかしよく見みれば
この部分、正しくは
SetArrayBoundary(i) = (2 ^ iMax) / 2 * (2 * i - 1)
であることに気が付いた。これに気づいた後は、早かった。
If iMax >= 4 Then Dim SetArrayBoundary() As Variant ReDim SetArrayBoundary(1 To 2 ^ (iMax - 2) - 1) For i = 1 To UBound(SetArrayBoundary) j = 2 ^ WorksheetFunction.RoundUp(WorksheetFunction.Log(i + 1, 2), 0) SetArrayBoundary(i) = (2 ^ iMax) / j * (2 * i - j + 1) Cells(i, 1) = i Cells(i, 4) = SetArrayBoundary(i) Next End If
ポイントは、ｉを直近の２の累乗に切り上げる点にあった。
これで、Select Caseによる場合分けが不要になった。よし、これで先に進める。
そう思ってから、気が付いた。この部分、新しく作っている範囲に含まれてる
から、わざわざ一般化する必要なかった・・・。
というわけで、今日からまた再開です。
参考まで。
再びトーナメント表作成 ⑥ クラスモジュール作成
先日から、トーナメント表作成の仕組みを焼き直ししている。
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 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) 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 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
テスト用のマクロがこちら。
Sub Hoge() Dim arr As Variant With New VBAProject.Tournament .init Range("B2:B27"), True, 9 arr = .TournamentSortedOrderArray End With Dim i As Long Dim c As Long For i = 1 To UBound(arr) If arr(i) <> vbNullString Then c = c + 1 arr(i) = StrConv(Format(c, "00:"), vbWide) & arr(i) Else arr(i) = "（欠番）" End If Next Range("E2").Resize(UBound(arr)) = WorksheetFunction.Transpose(arr) End Sub
実行した結果がこちらになる。
作った本人も毎回こんがらがるので、改めて解説。
例えば、上から20番目には誰をセットするか。
- 20番目には、昨年度11位の人をセットする。
- しかし昨年度11位の人は、ランダム並び替えで23位の人と入れ替えている。
- 23位の人は、寺井 友以乃さんである。
という三段階のプロセスを踏んでいる。
ようやくここまで辿り着いた。
次回からこれを、トーナメント表に成形します。
参考まで。
再びトーナメント表作成 ⑤ 人を配置してみる
昨日は、トーナメント表作成時に全大会の上位入賞者を良い感じに
分散する関数における「考慮漏れ」の改修について紹介した。
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
結果は以下のとおり。３回作成した結果を横並びにしてみた。
※各位の名前は、「今回並び順_前大会順位：氏名（出身県）」で表示。
- 何度やっても指定した上位８名は均等に散らばっていて、初戦では戦わない。
- 何度やっても上位から優先的にシードされている。
ということで、ややこしかった人の配置も一段落。ロジックは大体固まったので、ここからさらにブラッシュアップしてみよう。
次回に続きます。
参考まで。
再びトーナメント表作成 ④ 前大会の入賞者を良い感じに分散したい、を修正
先日から、トーナメント表の作成に取り組んでいる。数回前は、
前大会の入賞者を良い感じに分散させて、例えば前回の1位と2位が
一回戦で対戦しないよう工夫してみた。
infoment.hatenablog.com
この中で重大な考慮漏れがあったため、今回はそれを修正する。
例えば31人でトーナメントを作成する場合。今回の考え方では、架空の32人目も
加えてトーナメント表を作成し、32人目と対戦する人を不戦勝にする（=シード）
こととしていた。
しかし前回作成した関数では、1位と32位は対戦しない。そこも含めて、均等に
分散されてしまうからだ。
そこで、良い感じに分散したのちに、改めて1位と32位が、2位と31位が、3位と
30位が、・・・n位と32-n+1位が対戦するよう修正してみた。
Function GetTournamentOrderArray(player_count As Long, _ Optional invers_flag As Boolean = False) As Variant ' 作業用配列。最終的に戻り値となる。 Dim arr() As Variant ReDim arr(1 To 1) ' 初期値。選手が一人のとき。 arr(1) = 1 If player_count = 1 Then GetTournamentOrderArray = arr Exit Function End If ' WorksheetFunctionの表記短縮用。 Dim Wf As WorksheetFunction Set Wf = WorksheetFunction ' 選手の数から求めるトーナメントサイズ。 Dim TournamentSize As Long TournamentSize = 10 ^ (Wf.Ceiling_Math(Wf.Log10(player_count), Wf.Log10(2))) Dim i As Long Dim j As Long ' 選手の数に併せて大きくなるトーナメントの仮格納用配列。 Dim TempArray As Variant ' 底の変換公式を用いて、配列を何回２倍するか求めている。 For i = 1 To Wf.Log(TournamentSize) / Wf.Log(2) 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 TournamentSize If arr(i) > TournamentSize / 2 Then ' ４人一組で評価するとき、２番目は１番目と、３番目は４番目と ' ペアになることから、４で割った余りで処理を変更する。 Select Case i Mod 4 Case 2: arr(i) = TournamentSize - arr(i - 1) + 1 Case 3: arr(i) = TournamentSize - arr(i + 1) + 1 End Select End If Next TempArray = arr ' 配列の最後を１位にしたい場合用。配列の順序をひっくり返す。 If invers_flag Then For i = 1 To UBound(arr) arr(i) = TempArray(UBound(TempArray) - i + 1) Next End If GetTournamentOrderArray = arr End Function
それでは再度、↓で確認してみよう。
Sub Test() Dim arr As Variant Dim i As Long For i = 1 To 18 arr = GetTournamentOrderArray(i, True) ' 貼り付けて確認。 Cells(1, i).Resize(UBound(arr)) = WorksheetFunction.Transpose(arr) Next End Sub
結果がこちら。
今度こそ、前大会の上位者から優先的にシードされるようになった。
危ない、危ない。次回に続きます。
参考まで。
再びトーナメント表作成 ③ 順番をランダムに並べ替えたい－２
昨日は、トーナメントに於いて対戦カードをランダムにするために、
配列の順番をランダムに並べ替えることに挑戦した。
infoment.hatenablog.com
書き始めた時刻が遅かったこともあり、残念ながらタイムアウトとなった。
今日は、昨日の続きから。
理屈の部分は、昨日の内に終えている。
ここで要件として、
ｎ番目以降からランダムソートしたい
を追加してみよう。目的は、例えば
前回入賞者（１～４位）はトーナメント内の位置を固定し、５位以降の選手はランダムに配置したい
などの要求に対応するためだ。
以上を踏まえて作成したのがこちら。なお、配列ソートの関数については、
以前作成したものを流用している。
Function GetRandomSortArray(total As Long, Optional start_number As Long = 1) As Variant ' 作業用配列。 Dim TempArray As Variant ReDim TempArray(1 To total) ' 戻り値用配列。 Dim arr As Variant ReDim arr(1 To total) Dim i As Long For i = 1 To total ' ソートしない範囲。 If i < start_number Then TempArray(i) = i ' ソート範囲。iMax以上の桁でソートする。 ' このときtotalの桁数範囲には、元の数字が保存されている。 Else TempArray(i) = CLng(WorksheetFunction.RandBetween(1, 100) * _ (10 ^ Len(CStr(total))) + i) End If Next ' 配列ソート。 TempArray = SortArray(TempArray) ' 保存された元の数字を取り出す。 ' SortArray関数を使用すると、配列が０始まりになるので注意。 For i = total To 1 Step -1 arr(i) = Right(TempArray(i - 1), CLng(Len(CStr(total)))) * 1 Next GetRandomSortArray = arr End Function
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
それでは、テストしてみよう。１～３２の数字について、５番目以降から
ランダムソートしてみる。
Sub Test() Dim arr As Variant arr = GetRandomSortArray(32, 5) Range("A1:A32") = WorksheetFunction.Transpose(arr) End Sub
結果がこちら。意図したとおり、１～４は順番通りで、５番目からランダムに
並び替えられている。
これはこれで、ちょっとややこしかったかな。
次回に続きます。
参考まで。
再びトーナメント表作成 ③ 順番をランダムに並べ替えたい－１
昨日はトーナメント表作成において、なるべく全大会の入賞者が初戦で
ぶつからないよう、良い感じに分散させることに挑戦した。
infoment.hatenablog.com
しかしそうは言っても、完全ランダムで配置したいこともあるだろう。
ということで今日は、配列をランダムに並べ替えることに挑戦する。
実は今までにも、何度か挑戦したことがあった。そのときの作戦はこうだ。
例）1～32をランダムな順序で配列に格納したい。
- 辞書２を作成する。辞書２のkeyおよびitemには順に1～32をセットしておく。
- 1～32の数字を乱数で作成する。
- 作成した数字が辞書２のキーに存在するか、評価する。存在する場合、辞書１のkeyにセットする。このとき、itemの値は不問。
- 上記でセットしたkeyの値を、辞書２のkeysからRemoveする。
- 繰り返し（２. へ戻る）
これにより、どの数字が使われたか、使われていないかが判るという理屈。
最初の内は乱数の生成結果が重複することはまれだが、後半になるにつれ
何度も乱数生成を要する確率が上がっていくことになる。
↓ 実際試してみると、このケースでは合計で93回も乱数を生成している。
同じケースを1000回繰り返し、乱数生成の合計平均を求めた結果は、
約130回であった。やはり、結構かかってしまう。
そこで、もっと時間が掛からない方法はないものかと考えて、行きついた
結果がこちら。
例）1～32をランダムな順序で配列に格納したい。
- １～32の各々に、乱数「１～100」×100を乗じて足し算する。
- 足し算した結果を昇順（または降順）ソートする。
- ソートされた順に、下二桁を取り出して配列に格納する。
↓ まず並べ替え用の数を足して、
↓これを並べ替えて、下二桁を抽出。
並べ替えは後から加えたランダムな数が優先される一方で、下二桁は元の数字が
保存されているので、これでランダム並べ替えが成立するという仕組みだ。
と、ここで時間切れ。明日に続きます。
参考まで。
