再びトーナメント表作成 ⑥ クラスモジュール作成 - Infomentのブログ～Excel VBA奮闘記～

先日から、トーナメント表作成の仕組みを焼き直ししている。
infoment.hatenablog.com
今回は、これを一旦クラスモジュールに作り替えてみた。

クラスモジュールにした理由は至って単純で、複数回登場する値を使いまわししたかったら。しかし未熟の致すところで、至るところに自ら落とし穴を掘っては嵌りの繰り返しで、前回からこんなに時間が経ってしまった。

クラスモジュール化が判っているなら、最初からそのように作る方がよさそうだ。

という訳で、大晦日にようやく纏まった時間が取れて、形になったのがこちら。

Option Explicit

Public PlayerRange As Range
Public PlayerDict As Object
Public InversFlag As Boolean
Public StartNumber As Long
Dim Wf As WorksheetFunction
Dim NetPalyerNumber As Long
Dim TournamentSize As Long
Dim PlayerCount As Long

Private Sub Class_Initialize()
    Set Wf = WorksheetFunction
End Sub

Public Sub init(Optional player_range As Range, _
                Optional invers_flag As Boolean = False, _
                Optional start_number As Long = 1)
    
    Dim arr As Variant
    Dim i As Long
        If Not player_range Is Nothing Then
            Set PlayerRange = player_range
        Else
            Set PlayerRange = Selection
        End If
        InversFlag = invers_flag
    
    Set PlayerDict = CreateObject("Scripting.Dictionary")
    Dim r As Range
        For Each r In PlayerRange
            If r.Value <> vbNullString Then
                NetPalyerNumber = NetPalyerNumber + 1
                PlayerDict(NetPalyerNumber) = r.Value
            End If
        Next

        ' 一回戦の人の配置を、前大会の何位からランダムに入れ替えるか。
        StartNumber = start_number

        ' 選手の数から求めるトーナメントサイズ（決勝までの段数）。
        TournamentSize = Wf.Ceiling_Math(Wf.Log10(NetPalyerNumber), Wf.Log10(2)) / Wf.Log10(2)

        ' 一回戦の人数。
        PlayerCount = 2 ^ TournamentSize

End Sub

Private Property Get TournamentOrderArray() As Variant
    
    ' 作業用配列。最終的に戻り値となる。
    Static arr As Variant
    If Not IsEmpty(arr) Then
        TournamentOrderArray = arr
        Exit Property
    End If
    
    ReDim arr(1 To 1)
    ' 初期値。選手が一人のとき。
        arr(1) = 1
        If PlayerCount = 1 Then
            TournamentOrderArray = arr
            Exit Property
        End If
    
    Dim i As Long
    Dim j As Long
    
    ' 選手の数に併せて大きくなるトーナメントの仮格納用配列。
    Dim TempArray As Variant
        For i = 1 To TournamentSize
            ReDim TempArray(1 To UBound(arr) * 2)
            For j = 1 To UBound(arr)
                ' 元の配列内の数値を、上から奇数で、下から偶数でセット。
                TempArray(j) = arr(j) * 2 - 1
                TempArray(UBound(TempArray) + 1 - j) = arr(j) * 2
            Next
            arr = TempArray
        Next
        
        ' 上位半数の相手を改めてセット。
        ' 例えば32人のトーナメントでは、1と32が、2と31が、3と30が・・・nと33-nが
        ' ペアになるようにする。※優先的に前回上位者を一回戦シードとするため。
        For i = 1 To PlayerCount
            If arr(i) > PlayerCount / 2 Then
                ' ４人一組で評価するとき、２番目は１番目と、３番目は４番目と
                ' ペアになることから、４で割った余りで処理を変更する。
                Select Case i Mod 4
                    Case 2: arr(i) = PlayerCount - arr(i - 1) + 1
                    Case 3: arr(i) = PlayerCount - arr(i + 1) + 1
                End Select
            End If
        Next
        TempArray = arr
        
        ' 配列の最後を１位にしたい場合用。配列の順序をひっくり返す。
        If InversFlag Then
            For i = 1 To UBound(arr)
                arr(i) = TempArray(UBound(TempArray) - i + 1)
            Next
        End If
        
        TournamentOrderArray = arr

End Property

Private Property Get RandomSortDict() As Object

    Static Dict As Object
        If Not Dict Is Nothing Then
            Set RandomSortDict = Dict
            Exit Property
        End If

    ' 作業用配列。
    Dim TempArray As Variant
    ReDim TempArray(1 To NetPalyerNumber)
    ' 戻り値用配列。
    Dim arr As Variant
    ReDim arr(1 To NetPalyerNumber)

    Dim i As Long
        For i = 1 To NetPalyerNumber
            ' ソートしない範囲。
            If i < StartNumber Then
                TempArray(i) = i
            
            ' ソート範囲。iMax以上の桁でソートする。
            ' このときtotalの桁数範囲には、元の数字が保存されている。
            Else
                TempArray(i) = CLng(WorksheetFunction.RandBetween(1, 100) * _
                              (10 ^ Len(CStr(PlayerCount))) + i)
            End If
        Next

        ' 配列ソート。
        TempArray = SortArray(TempArray)
        
        ' 保存された元の数字を取り出す。
        ' SortArray関数を使用すると、配列が０始まりになるので注意。
        For i = NetPalyerNumber To 1 Step -1
            arr(i) = Right(TempArray(i - 1), CLng(Len(CStr(NetPalyerNumber)))) * 1
        Next

    Set Dict = CreateObject("Scripting.Dictionary")
        For i = 1 To NetPalyerNumber
            Dict(i) = arr(i)
        Next
        
        If NetPalyerNumber < PlayerCount Then
            For i = NetPalyerNumber + 1 To PlayerCount
                Dict(i) = i
            Next
        End If
        
    Set RandomSortDict = Dict

End Property

Public Function SortArray(ByVal source_array As Variant, _
                       Optional sort_order As Excel.XlSortOrder = xlAscending) As Variant
                       
    Dim aryList As Object
    Set aryList = CreateObject("System.Collections.ArrayList")
    Dim s As Variant
    
        For Each s In source_array
            Call aryList.Add(s)
        Next
    
        Select Case sort_order
            Case xlAscending
                ' 昇順でソート。
                Call aryList.Sort
            Case xlDescending
                ' 昇順でソートののち、降順へ反転。
                Call aryList.Sort
                Call aryList.Reverse
        End Select
    
        SortArray = aryList.ToArray
        
End Function

Public Property Get TournamentSortedOrderArray()

    Dim i As Long
    Dim arr() As Variant
    ReDim arr(1 To PlayerCount)
        For i = 1 To PlayerCount
            arr(i) = PlayerDict(RandomSortDict(TournamentOrderArray(i)))
        Next
        TournamentSortedOrderArray = arr
        
End Property

テスト用のマクロがこちら。

Sub Hoge()

    Dim arr As Variant
    With New VBAProject.Tournament
        .init Range("B2:B27"), True, 9
        arr = .TournamentSortedOrderArray
    End With
    
    Dim i As Long
    Dim c As Long
        For i = 1 To UBound(arr)
            If arr(i) <> vbNullString Then
                c = c + 1
                arr(i) = StrConv(Format(c, "00:"), vbWide) & arr(i)
            Else
                arr(i) = "（欠番）"
            End If
        Next
        
        Range("E2").Resize(UBound(arr)) = WorksheetFunction.Transpose(arr)
            
End Sub