再びトーナメント表作成 ➈-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

これで、対戦表およびトーナメント作成までの機能が完成した。

それでは次回、実際に作成されたものをみてみよう。

参考まで。

※その後、数々の仕様変更があって、いったん保留となりました。