阿弥陀編：最終回　～クラスモジュールへの旅～ - Infomentのブログ～Excel VBA奮闘記～

先日は、あみだくじを一斉にスタートさせることで、結果が出るまでの待ち時間を短縮してみた。
infoment.hatenablog.com

本日は、阿弥陀編の最終回（と、「火の鳥」っぽい題名を付けてみた）。
f:id:Infoment:20190805222512p:plain

といっても、行ったのは以下の二つ。

クラスモジュール化（ワンパターン？）
梯子部分を辿る時、名前も一緒に表示させる。

クラスモジュール部分は、それなりにボリュームがある。
なので、↓ こちらに畳んで置いておく。

クラスモジュール（AmidaClass）

Option Explicit

Public NameRange As Range
Public StartRange As Range
Public WinnersNumber As Long
Private myTintAndShade As Double

Private Sub SetEntry()
    StartRange.Resize(, UBound(NameArray)) = WorksheetFunction.Transpose(NameArray)
End Sub

' あみだくじの梯子部分を作成
Private Sub MakeLadderLine()
    ' 指定範囲に縦線を描画。
    Dim BordersIndex As Variant
        For Each BordersIndex In Array(xlEdgeRight, xlInsideVertical)
            LadderRange.Borders(BordersIndex).LineStyle = xlContinuous
        Next
    
    ' 指定範囲の各セルについて、描画ＯＫの場合に無作為に、
    ' セルの下辺に線を引く。
    Dim r As Range
        For Each r In LadderRange
            If LineCriteria(LadderRange, r) Then
                Dim rndIndex As Long
                ' ０か１を無作為に決定。
                rndIndex = WorksheetFunction.RandBetween(0, 1)
                ' 無作為の決定内容に従い、線を引くか引かないかが決定する。
                r.Borders.Item(xlEdgeBottom).LineStyle = (xlContinuous - xlNone) * rndIndex + xlNone
            End If
        Next
End Sub

'線を引くか引かないかの抽選
Private Function LineCriteria(all_range As Range, target_range As Range) As Boolean
    ' 指定範囲の１列目ＮＧ。
    ' ※参加者氏名を線の左側に書く都合上。
    If target_range.Column = all_range(1).Column Then
    ' 指定範囲の１番下辺には線を引かない。
    ' ※ゴールに到達できなくなるため。
    ElseIf all_range(1).Row + all_range.Rows.Count - 1 = target_range.Row Then
    ' セルの上辺にも線が有る場合ＮＧ。
    ' ※ある程度線の間隔を確保するため。
    ElseIf target_range.Borders.Item(xlEdgeTop).LineStyle <> xlNone Then
    ' 左隣に線が無ければＯＫ。
    ' ※同じ高さで線が並ぶと、どこで下に降りるか判断できなくなるため。
    ElseIf target_range.Offset(, -1).Borders.Item(xlEdgeBottom).LineStyle = xlNone Then
        LineCriteria = True
    End If
End Function

' あみだくじの梯子に沿い、引数で与えたRangeから
' 次に進むRangeを取得する。
Private Function GetNextRange(source_range As Range, source_color As Long) As Range

    '２行２列の左上セルの右側が無ければ、あみだくじを抜けきったことになる。
    With source_range.Item(1)
        If .Borders(xlEdgeRight).LineStyle = xlNone Then
            Set GetNextRange = Nothing
            .Interior.Color = source_color
            .Interior.TintAndShade = myTintAndShade
            Exit Function
        End If
    End With

    ' 道筋が分かるよう、たどったセルを塗りつぶす。
    source_range.Item(1).Interior.Color = source_color
    source_range.Item(1).Interior.TintAndShade = myTintAndShade
    With source_range.Item(1).Borders.Item(xlEdgeRight)
        .Color = source_color
        .Weight = xlMedium
        .LineStyle = xlDouble
    End With
    
    ' 各セルの底線を配列に格納することで、以降のチェックを
    ' ループ内で実行できるようにしている。
    Dim Border_Bottom(1 To 2) As Border
    Dim i As Long
        For i = 1 To UBound(Border_Bottom)
            Set Border_Bottom(i) = source_range.Item(i).Borders(xlEdgeBottom)
        Next
    
    ' 進行方向の確認。
    ' 底線が無い場合、まっすぐ下に進む（⇒ dx＝０のまま）。
    Dim dx As Long: dx = 0
        For i = 1 To 2
            If Border_Bottom(i).LineStyle <> xlNone Then
                dx = 2 * i - 3
                Border_Bottom(i).Color = source_color
                Border_Bottom(i).Weight = xlMedium
                Border_Bottom(i).LineStyle = xlDouble
                Exit For
            End If
        Next
        
    Set GetNextRange = source_range.Offset(1, dx)
End Function

'参加者全員を一斉スタートさせ､
'同時に一段ずつ下りながらゴールを目指す。
Private Sub Solution()
    ' 各参加者の名前がセットされたセル範囲。
    Dim myRng() As Range
    ReDim myRng(1 To LadderRange.Columns.Count)
    
    ' 各参加者の名前に紐づく色。
    Dim PersonColor() As Long
    ReDim PersonColor(1 To UBound(myRng))
    
    Dim i As Long
        For i = 1 To UBound(myRng)
            Set myRng(i) = LadderRange(i).Resize(2, 2)
            
            ' 参加者別に、無作為に色をセット。
            PersonColor(i) = WorksheetFunction.RandBetween(150 ^ 3, 255 ^ 3)
            myRng(i).Cells(0, 1).Interior.Color = PersonColor(i)
            
            ' 濃い色がセットされると見難くなるので、少し薄くしておく。
            myRng(i).Cells(0, 1).Interior.TintAndShade = myTintAndShade
        Next i
    Dim counter As Long: counter = 1
        Do Until myRng(1) Is Nothing
        
            ' 一段下げる毎に、上の段の色を消す。
            ' 一行目の名前の塗りつぶしを消さないよう、２回目から消している。
            If counter >= 2 Then
                LadderRange.Rows(counter - 1).Interior.Color = xlNone
                LadderRange.Rows(counter - 1).Value = vbNullString
            End If
            
            ' 各参加者について、次に進むべきセル範囲を取得する。
            For i = 1 To UBound(myRng)
                On Error Resume Next
                myRng(i).Item(1) = NameArray(i, 1)
                Set myRng(i) = GetNextRange(myRng(i), PersonColor(i))
            Next
            
            counter = counter + 1
            Application.Wait [Now() + "00:00:00.5"]
        Loop
End Sub

' 当選者をセット。
Private Sub WinnerSet()
    Dim LastRow As Range
    Set LastRow = LadderRange.Rows(LadderRange.Rows.Count).Offset(2)
    
    Dim r As Range
        Do
            For Each r In LastRow.Cells
                r = WorksheetFunction.RandBetween(0, 1)
            Next
        Loop Until WorksheetFunction.Sum(LastRow) = WinnersNumber
        LastRow.Replace 0, vbNullString
        LastRow.Replace 1, "当選"
End Sub

' あみだくじ開始。
Public Sub StartAmida()
    SetEntry
    MakeLadderLine
    WinnerSet
    Solution
End Sub

Private Property Get NameArray() As Variant
    Dim arr() As Variant
        arr = NameRange.Value
        NameArray = arr
End Property

Private Property Get LadderRange() As Range
    ' あみだくじを作成する範囲を設定。
    Set LadderRange = StartRange.Offset(1).Resize(UBound(NameArray) * 2, UBound(NameArray))
End Property

Private Sub Class_Initialize()
    myTintAndShade = 0.6
End Sub

標準モジュール

毎度のごとく、クラスモジュールに殆ど渡してしまったため、こちらは実にアッサリしている。

Sub test()
    Dim AC As AmidaClass
    Set AC = New AmidaClass
    
    ' 参加者の名前が書かれた範囲をセット。
    Set AC.NameRange = Range("A5:A11")
    
    ' 当選人数をセット。
        AC.WinnersNumber = Range("B2")
        
    ' あみだくじの左上端をセット。
    Set AC.StartRange = Range("D5")
    
    ' あみだくじスタート。
        AC.StartAmida
End Sub