再びトーナメント表作成 ➈-4 特定名簿からの作成 - Infomentのブログ～Excel VBA奮闘記～

特定名簿からのトーナメント作成ツールを、少しずつ紹介中。
本日も、先日の続きから。

本日は、トーナメントの作成部分。長いので、前半と後半で日を分けて紹介。

Sub 対戦表作成(Optional match_type As MatchType = en形)

    Call 名簿データ取得
    
    ' 形および組手の名簿は、PowerQueryで作成。
    ' 名簿テーブル。
    Dim Tb As ListObject
    ' 対戦表テーブル。
    Dim DstTb As ListObject
    ' トーナメントを作成するシート名。
    Dim SheetName As String
        Select Case match_type
            Case MatchType.en形
                Set Tb = S22_名簿_形.Tb
                Set DstTb = S24_対戦表_形.Tb
                Set DDict = New Scripting.Dictionary
                SheetName = "形トーナメント"
             Case MatchType.en組手
                Set Tb = S23_名簿_組手.Tb
                Set DstTb = S25_対戦表_組手.Tb
                SheetName = "組手トーナメント"
        End Select
    
    ' 作成済みシートの有無確認。ある場合は削除する。
    Dim Ws As Worksheet
        Application.DisplayAlerts = False
        For Each Ws In Worksheets
            If Ws.Name = SheetName Then
                Ws.Delete
                Exit For
            End If
        Next
        Application.DisplayAlerts = True
    
    ' 名簿テーブルの更新。BackgroundQueryをFalseにすることで、
    ' QueryTableの更新が終わってから次のステップに進む。
        Tb.QueryTable.Refresh BackgroundQuery:=False
    
    ' 組み合わせ表を格納するための配列。
    Dim arr As Variant
    ' 同一所属間対戦をチェックするための辞書。
    Dim Dict As Scripting.Dictionary
    Set Dict = New Scripting.Dictionary
    ' ループ用変数。
    Dim i As Long
    Dim j As Long
    ' ループカウンタ。
    Dim LoopCount As Long
    ' 重複数。形と組手で同じ人と対戦した回数。
    Dim DuplicateTimes As Long
    ' 許容重複回数。
    Dim AllowableDuplicateTimes As Long: AllowableDuplicateTimes = 2
    ' 再履行許容回数。重複などが解消できない場合、無限ループに入る恐れがある。
    ' そのため、再履行の最大値を設定しておく。
    Dim LoopCountMax As Long: LoopCountMax = 10000
    Dim MsgboxResult As VbMsgBoxResult
    Dim r As Range
    ' 同所属対戦を許容するブロックの人数。
    ' 例）2 とした場合、一回戦のみ同所属対戦不可とする。
    ' 　　　4 とした場合、二回戦まで同所属対戦不可とする。一回戦がシードの場合、
    ' 　　　二回戦まで不可としておくことで、シード戦の同所属対戦を回避できる。
    ' 　　　出場団体が少ないほど同所属対戦が起きやすくなるため、調整が必要。
    Dim DupTrial As Long: DupTrial = 4