再びトーナメント表作成 ➈-6 特定名簿からの作成
特定名簿からのトーナメント作成ツールを、少しずつ紹介中。
本日も、昨日の続きから。
今日は、三つに分けたサブプロシージャの最後。
Dim Sh As Worksheet Set Sh = ActiveSheet ' トーナメント作成用シートを変数にセットしてリネーム。 Sh.Name = SheetName ' 各選手の「番号」を、辞書を利用して「人名」に置換。 For Each r In Sh.UsedRange.Columns(1).Cells If r <> vbNullString Then r = PDict(r.Value) End If Next ' 配列内で、選手名が空欄であれば「不戦敗」に置き換える。これにより、 ' 対戦相手がシード選手となる。 For i = 1 To UBound(arr) If arr(i, 列名.enNo) = vbNullString Then arr(i, 列名.enNo) = "不戦敗" ' 形のトーナメント作成である場合、この後に続く組手トーナメント作成時に ' 形と同カードが発生しないよう、形の対戦組み合わせを辞書に記録する。 ElseIf match_type = en形 Then If WorksheetFunction.IsOdd(i) Then If arr(i, 列名.enNo) <> vbNullString And arr(i + 1, 列名.enNo) <> vbNullString Then DDict(arr(i, 列名.enNo)) = arr(i + 1, 列名.enNo) DDict(arr(i + 1, 列名.enNo)) = arr(i, 列名.enNo) End If End If End If Next With DstTb If .ListRows.Count > 0 Then .DataBodyRange.Delete End If .ListRows.Add .DataBodyRange.Cells(1, 1).Resize(UBound(arr), UBound(arr, 2)) = arr End With If DuplicateTimes > 0 Then MsgBox SheetName & "で、二回戦までに " & DuplicateTimes & " 箇所で同所属選手対戦の恐れがあります。確認および調整をお願いします。" End If End Sub
これで、対戦表およびトーナメント作成までの機能が完成した。
それでは次回、実際に作成されたものをみてみよう。
参考まで。
※その後、数々の仕様変更があって、いったん保留となりました。