空手の形の試合の得点計算　～マクロ④ 同順位の優劣決定～

昨日は試行錯誤の末、結局同じ順位のグループが何組あるかまでを求めた。悩んでいたら時間だけが過ぎて、全然進まなかった。
そこで今回は、同じ順位の点数に最低点を加え、順位を求める方法を模索する。
f:id:Infoment:20181113213342p:plain

今回は、かなりのドタバタ劇になった。もっとスマートに作れればいいのに。
作戦は、こうだ。

各順位の人数で辞書（連想配列）作成。
１位から最下位まで、繰り返し処理。
・辞書に順位がある場合のみ、処理を行う。
・登録人数が一人の場合、その順位はその一人で確定となる。
・登録人数が複数いる場合、まず最低点を含む合計をコレクションに登録。
・各人の順位が、コレクション中の何位であるかを求める。
・現在の順位に、求めた順位を加えて１引いたものを、新たな順位とする。

文字にするとこんな感じで、コードにすると以下のようになる。

標準モジュール

Sub GetRank()
    Dim PointTable As ListObject
    Set PointTable = ActiveSheet.ListObjects("採点表")
    
    ' 順位のセルをリセット。
    PointTable.ListColumns("順位").DataBodyRange = ""
    
    ' 各選手の成績を配列化。
    Dim Player() As KarateRankClass
    ReDim Player(1 To PointTable.DataBodyRange.Rows.Count)
    
    ' 最高点と最低点を除く合計点格納用配列。
    Dim TotalSeq_1st() As Variant
    ' 最高点を除く合計点格納用配列。
    Dim TotalSeq_2nd() As Variant
    ' 合計点格納用配列。
    Dim Totalseq_3rd() As Variant
    
    ReDim TotalSeq_1st(1 To UBound(Player))
    ReDim TotalSeq_2nd(1 To UBound(Player))
    ReDim Totalseq_3rd(1 To UBound(Player))
    
    ' 各選手のレコードから、各情報を取得。
    Dim i As Long
        For i = 1 To UBound(Player)
            Set Player(i) = New KarateRankClass
            Player(i).myRecord = PointTable.DataBodyRange.Rows(i)
            TotalSeq_1st(i) = Player(i).Total_1st
            TotalSeq_2nd(i) = Player(i).Total_2nd
            Totalseq_3rd(i) = Player(i).Total_3rd
        Next
        
    Dim SQC As SeaquenceClass
    Set SQC = New SeaquenceClass
        
        TotalSeq_1st = SQC.SortSeq(TotalSeq_1st, myDescending)
        
    ' 以降、今回変更した箇所。
    Dim RankDict As Dictionary
    Set RankDict = New Dictionary
    
        For i = 1 To UBound(Player)
            Player(i).Rank_1st = SQC.RankSeq(Player(i).Total_1st, TotalSeq_1st)
            If RankDict.Exists(Player(i).Rank_1st) Then
                RankDict(Player(i).Rank_1st) = RankDict(Player(i).Rank_1st) + 1
            Else
                RankDict(Player(i).Rank_1st) = 1
            End If
        Next

    Dim j As Long
        For i = 1 To UBound(Player)
            If RankDict.Exists(i) Then
                If RankDict(i) = 1 Then
                    For j = 1 To UBound(Player)
                        If Player(j).Rank_1st = i Then
                            Player(j).Rank_2nd = i
                            Debug.Print i & "：" & Player(j).PlayerName
                            Exit For
                        End If
                    Next
                Else
                    Dim col As Collection
                    Set col = New Collection
                    For j = 1 To UBound(Player)
                        If Player(j).Rank_1st = i Then
                            col.Add Player(j).Total_2nd
                        End If
                    Next
                    For j = 1 To UBound(Player)
                        If Player(j).Rank_1st = i Then
                            Player(j).Rank_2nd = Player(j).Rank_1st + SQC.RankSeq(Player(j).Total_2nd, SQC.ToArray(col)) - 1
                            Debug.Print Player(j).Rank_2nd & "：" & Player(j).PlayerName
                        End If
                    Next
                End If
            End If
        Next
End Sub