あみだくじの「梯子の部分」を、マクロで作ってみる

さて、昨日までは、罫線描画のあれこれを話題にしてみた。
infoment.hatenablog.com
infoment.hatenablog.com

今日はこれらを踏まえ、また上記投稿の期間中に寄せられた知見を拝借して、あみだくじの「梯子の部分」を作ってみる。

※元ネタはこちらです。
koroko.hatenablog.com

後で変更するとして、まず選択範囲に梯子を作成してみる。

1. 選択範囲に、縦の線を引く。
2. 各セルについて、下辺に線を引く（ランダム）。

まず選択範囲があって、

縦線を引く。

各セルについて、順番にランダムに、下辺に線を引く。

まず、線を引いて良いかどうかの関数を作ることにした。

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 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

では、早速テストしてみよう。

Sub test()
    MakeLadderLine Selection
End Sub

何本か書き足したくなる結果となった。
実際に使う場合は、もう少し調整が必要かも。

参考まで。