一斉にあみだくじ

前回は作成したあみだくじで、選択した任意の参加者を自動でゴールまで辿らせてみた。
infoment.hatenablog.com

今回は、あみだくじの作成から結果の表示までを、自動で一気にやってみる。

あみだくじで、一人ずつゴールまで辿ると、全ての結果が出るには

一人分の所要時間 × 人数

が必要となる。大人数ともなれば、待ちきれなくなることも多い。

そこで今回は、人数に関係なく凡そ同じぐらいの所要時間で結果が出るよう、一斉にあみだくじをスタートさせてみた。

' あみだくじの梯子部分を作成
Sub MakeLadderLine(target_range As Range)
    ' 指定範囲に縦線を描画。
    Dim BordersIndex As Variant
        For Each BordersIndex In Array(xlEdgeRight, xlInsideVertical)
            target_range.Borders(BordersIndex).LineStyle = xlContinuous
        Next
    
    ' 指定範囲の各セルについて、描画ＯＫの場合に無作為に、
    ' セルの下辺に線を引く。
    Dim r As Range
        For Each r In target_range
            If LineCriteria(target_range, 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

'線を引くか引かないかの抽選
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

'参加者全員を一斉スタートさせ､
'同時に一段ずつ下りながらゴールを目指す。
Sub Solution(start_range As Range)
    ' 各参加者の名前がセットされたセル範囲。
    Dim myRng() As Range
    ReDim myRng(1 To start_range.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) = start_range(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 = 0.6
        Next i
    Dim counter As Long: counter = 1
        Do Until myRng(1) Is Nothing
        
            ' 一段下げる毎に、上の段の色を消す。
            ' 一行目の名前の塗りつぶしを消さないよう、２回目から消している。
            If counter >= 2 Then
                start_range.Rows(counter - 1).Interior.Color = xlNone
            End If
            
            ' 各参加者について、次に進むべきセル範囲を取得する。
            For i = 1 To UBound(myRng)
                Set myRng(i) = GetNextRange(myRng(i), PersonColor(i))
            Next
            
            counter = counter + 1
            Application.Wait [Now() + "00:00:00.5"]
        Loop
End Sub

' あみだくじの梯子に沿い、引数で与えたRangeから
' 次に進むRangeを取得する。
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 = 0.6
            Exit Function
        End If
    End With

    ' 道筋が分かるよう、たどったセルを塗りつぶす。
    source_range.Item(1).Interior.Color = source_color
    source_range.Item(1).Interior.TintAndShade = 0.6
    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

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

それでは、こちらで確認してみよう。

Sub test()

    ' 参加者の氏名を取得。
    Dim NameArray() As Variant
        NameArray = Range("A5:A11")
    
    ' 参加者をあみだくじにセット。
        Range("D5").Resize(, UBound(NameArray)) = WorksheetFunction.Transpose(NameArray)
    
    ' 当選人数を取得。
    Dim WinnersNumber As Long
        WinnersNumber = Range("B2").Value
    
    ' あみだくじを作成する範囲を設定。
    Dim LadderRange As Range
    Set LadderRange = Range("D6").Resize(UBound(NameArray) * 2, UBound(NameArray))
    
    ' あみだくじの梯子部分を描画。
    Call MakeLadderLine(LadderRange)
    
    ' あみだくじの当選者をセット。
    Call WinnerSet(LadderRange, WinnersNumber)
    
    ' 抽選開始。
    Call Solution(LadderRange)
    
End Sub

結果、このようになった。

「似通った色がセットされてしまうと判別しにくい」など、まだまだ直すべき点は多い。でも今日は、取り敢えずここまでとします。

参考まで。