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

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

昨日は「前半と後半の二回に分ける」としたが、それでも長かった。
ということで、今日は中盤のご紹介。同一サブプロシージャの途中から始まるため分り難くなっているが、最後に改めてまとめて紹介するため、今はご勘弁。

        Do
            With New VBAProject.Tournament
                ' トーナメント作成の初期設定。
                ' 前回順位の最大値を取得し、それ以降をランダムに並び替える。
                .init Tb.ListColumns(列名.enNo).DataBodyRange, True, _
                      WorksheetFunction.Max(Tb.ListColumns(列名.en前回形順位).DataBodyRange) + 1
                      
                    ' トーナメントの配列取得。
                    arr = TournamentArray(.TournamentSortedOrderArray, match_type)
                    
                    ' 同所属対戦を不可とするブロック単位で、同所属の対戦が無いかを確認する。
                    For i = 1 To UBound(arr) Step DupTrial
                        
                        ' 重複の有無は辞書で行う。そのため、ループに入るたびに辞書を空にしている。
                        Dict.RemoveAll
                        
                        For j = 0 To DupTrial - 1
                            
                            ' 一回戦においては空欄＝シードが存在するため、それ以外の場合で評価している。
                            ' keyの重複を不可とする仕様を利用しているため、itemは不問。今回はTrueとした。
                            If arr(i + j, 列名.en所属) <> vbNullString Then
                                If Not Dict.Exists(arr(i + j, 列名.en所属)) Then
                                    Dict(arr(i + j, 列名.en所属)) = True
                                Else
                                    ' 重複があった場合は、重複回数をカウントアップ。
                                    DuplicateTimes = DuplicateTimes + 1
                                End If
                            End If
                        Next
                    Next
                    
                    ' 重複回数が重複許容回数を下回る場合であって、且つ組手のトーナメントを作成している場合、
                    ' 一回戦で形トーナメントと同じ選手と対戦していないかを確認。対戦している場合は再組合せ。
                    If DuplicateTimes < AllowableDuplicateTimes And match_type = en組手 Then
                        For i = 1 To UBound(arr) Step 2
                            If DDict.Exists(arr(i, 列名.enNo)) Then
                                If DDict(arr(i, 列名.enNo)) = arr(i + 1, 列名.enNo) Then
                                    ' 同じ選手と対戦している場合、重複回数を強制的に重複許容回数とすることで
                                    ' 再抽選させる。
                                    DuplicateTimes = AllowableDuplicateTimes
                                    Exit For
                                End If
                            End If
                        Next
                    End If
                    
                    ' ループ回数が最大値を超えた場合の処理。
                    If LoopCount > LoopCountMax Then
                        MsgboxResult = MsgBox("組み合わせをランダムに" & LoopCountMax & "回作成しましたが、同所属の対戦を回避できませんでした。" & vbNewLine & _
                                                         "このままの組み合わせで継続しますか？", vbYesNo, "処理継続確認")
                        If MsgboxResult = vbNo Then
                            MsgBox "処理を中断しました。"
                            Exit Sub
                        Else
                            ' 同所属の対戦があるままトーナメント作成。人の手で最終調整。
                            .CreateTournament
                            Exit Do
                        End If
                    
                    ' 重複回数が許容重複回数を下回っている場合、トーナメント作成の条件達成。
                    ' トーナメントを作成してループを抜ける。
                    ElseIf DuplicateTimes < AllowableDuplicateTimes Then
                        .CreateTournament
                        Exit Do
                    End If
            End With
            LoopCount = LoopCount + 1
            
            ' 重複回数の初期化。
            DuplicateTimes = 0
        Loop