【VBA】あみだくじを作ってみる【再帰】

Excel VBA であみだくじを作ろう！

コロ子さんのブログに触発されて以前 Excel VBA で作ったあみだくじを記事にしてみました。コロ子さんとはアプローチの仕方が違いますが、実現にはいろいろな方法がありますね。
koroko.hatenablog.com

シートの作成

まずはシートの作成です。セルを方眼紙状（エクセル方眼紙）にしてあみだを作ります。
今回は幅を24px、高さを25px にしていますが、このあたりはお好みで。
あみだのルート（線）はグレーにしていますが、これもお好みで大丈夫です。
横線はこの通りでなくても構いません。

なお、A2セルの色を線の色と同じ（今回はグレー）にしておいてください。
シート名は「あみだくじ」としました。

VBAProject

コードを書く準備をします。
先ほど作成した「あみだくじ」シートのオブジェクト名を「wsMain」にします。
また、標準モジュールを追加しましょう。コードは標準モジュールに書いていきます。
標準モジュールのオブジェクト名はなんでもかまいませんが、ここでは「mdlMain」としています。

コードの作成

モジュールレベル変数の宣言

モジュールレベル変数を宣言します。
myColor は 「あみだくじ」シートの 1行目の各番号の色を格納する変数です。
baseColor は 「あみだくじ」シートの背景セルの色です。今回はエクセル的には「塗りつぶしなし」になっていますが、好みで他の色にしてもかまいません。

'[標準モジュール]
Option Explicit

Dim myColor As Long         '自分の色
Dim baseColor As Long       '地（背景）セルの色

くじを選ぶ

くじを選ぶ処理を書いていきます。インプットボックスで何番を選ぶかを聞いて、選んだ番号によって、スタートの列を決定しています。
1, 2, 3, 4, 9 以外が入力された場合は、再度入力を促すようにしました。9が入力されたら処理を終了します。
入力された番号で、列をセットします。
1 のときは 3列目、2 のときは 7列目、3 のときは 11列目、4 のときは 15列目 なので、Select Case で振り分けても構いませんが、今回は計算で求めてみました。
3列目、7列目、11列目、15列目なので、3, 7, 11, 15 の数列になっています。これは、初項 3、交差 4 の等差数列です。この等差数列の一般項を求める式は

よって

n が 1 のときは 、n が 2 のときは となって、求める結果が得られていることがわかります。

列をセットしたら、行の初期値として 変数 r に 1 を代入しておきます。

Public Sub Click_スタート()
    Dim r As Long       '行番号
    Dim c As Long       '列番号
    Dim idx As Long     'どれを選ぶか
    
    'どれを選ぶか？
    Do
        idx = Val(InputBox("何番を選択しますか？（9で終了）"))
        
        '入力された数字から該当の列番号を計算する
        If 0 < idx And idx <= 4 Then
            c = (4 * idx) - 1
        ElseIf idx = 9 Then
            Exit Sub
        Else
            c = 0
        End If
        
'        よくわからなければこちらでも…
'        Select Case idx
'            Case 1
'                c = 3
'            Case 2
'                c = 7
'            Case 3
'                c = 11
'            Case 4
'                c = 15
'            Case 9
'                Exit Sub
'            Case Else
'                c = 0
'        End Select

    Loop Until c > 0
    
    r = 1

    'ここにあみだくじ実行処理を記述
    
End Sub

色を取得する

くじの番号が決まったら、該当する色を取得して変数 myColor に格納します。
あわせて、背景色を変数 baseColor に格納します。今回は A1 セルの色を背景色として設定しています。

Public Sub Click_スタート()
    Dim r As Long       '行番号
    Dim c As Long       '列番号
    Dim idx As Long     'どれを選ぶか
    
    'どれを選ぶか？
    Do
        idx = Val(InputBox("何番を選択しますか？（9で終了）"))
        
        '入力された数字から該当の列番号を計算する
        If 0 < idx And idx <= 4 Then
            c = (4 * idx) - 1
        ElseIf idx = 9 Then
            Exit Sub
        Else
            c = 0
        End If

    Loop Until c > 0
    
    r = 1
    
'**** ここから追加 ****

    With wsMain
    
        '自分の色を取得
        myColor = .Cells(r, c).Interior.Color
        'A1セルから地（背景）の色を取得
        baseColor = .Range("A1").Interior.Color
        
        'あみだくじ実行
        
        'ゴールに "eureka!" を表示
    
    End With

'**** ここまで ****    

End Sub

あみだ実行部分（amidaDrive()）の実装

次のようなロジックであみだを進めています。詳しくはコード中のコメントを参考にしてください。

　　もし、右に行けるならば
　　　　右に行く
　　違えば、もし、左に行けるならば
　　　　左に行く
　　違えば、もし、下に行けるならば
　　　　下に行く
　　違えば
　　　　ゴール

プロシージャの最後に再帰呼び出しをしています。再帰呼び出しはゴールに到達するまで続きます。

'あみだくじの実行プロシージャ
'引数 <- goNext:次に行けるかどうか、r:行番号、c:列番号
'戻り値 -> 次に行けたかどうか
Private Function amidaDrive(ByRef goNext As Boolean, ByRef r As Long, ByRef c As Long) As Boolean

    If Not goNext Then
        '次に行けてなければそのまま goNext を返す（goNext は False になっています）
        amidaDrive = goNext
        '（amidaDrive = False のほうが直感的にわかりやすいかも）
    Else
    
        With wsMain
    
            '動きをわかりやすくするためのウェイト
            Application.Wait [Now()+"00:00:00.2"]
            
            '自分のいるセルを自分の色で着色する
            .Cells(r, c).Interior.Color = myColor
            
            '次に行けるかどうかを判定（この時点では goNext は True で渡されてきています）
            If .Cells(r, c + 1).Interior.Color <> baseColor And .Cells(r, c + 1).Interior.Color <> myColor Then
                '右のセルの色が、地の色でない かつ 自分の色でない 場合（＝グレーか もしくは 自分以外のプレイヤーの色 の場合）は右に行く
                c = c + 1
            ElseIf .Cells(r, c - 1).Interior.Color <> baseColor And .Cells(r, c - 1).Interior.Color <> myColor Then
                '右に行けなかった場合で、左のセルの色が、地の色でない かつ 自分の色でない 場合は左に行く
                c = c - 1
            ElseIf .Cells(r + 1, c).Interior.Color <> baseColor And .Cells(r + 1, c).Interior.Color <> myColor Then
                '右にも左にも行けなかった場合で、下のセルの色が、地の色でない かつ 自分の色でない 場合は下に行く
                r = r + 1
            Else
                '右にも左にも下にも行けない場合は次には行けないので goNext に False をセット
                goNext = False
            End If
        
            '上記の判定処理を元に自プロシージャを再帰呼び出し
            amidaDrive = amidaDrive(goNext, r, c)
        
        End With
    
    End If
    
End Function

あみだ実行部分の呼び出し

上で作成した「amidaDrive()」を呼び出します。「amidaDrive()」はゴールに到達するまで再帰処理を続けます。
変数 r と c は参照渡しで渡されているので、再帰処理中に更新されていきます。
処理が終了したときにはゴールのセルの行番号、列番号が格納されています。
到達したセルの 1 つ下のセルに「eureka!」と表示します。なぜ「eureka!」なのかというと、それはまぁ、アミダ（アミタ）ドライブですから（ｗ

Public Sub Click_スタート()
    Dim r As Long       '行番号
    Dim c As Long       '列番号
    Dim idx As Long     'どれを選ぶか
    
    'どれを選ぶか？
    Do
        idx = Val(InputBox("何番を選択しますか？（9で終了）"))
        
        '入力された数字から該当の列番号を計算する
        If 0 < idx And idx <= 4 Then
            c = (4 * idx) - 1
        ElseIf idx = 9 Then
            Exit Sub
        Else
            c = 0
        End If

    Loop Until c > 0
    
    r = 1
    
    With wsMain
    
        '自分の色を取得
        myColor = .Cells(r, c).Interior.Color
        'A1セルから地（背景）の色を取得
        baseColor = .Range("A1").Interior.Color

'**** ここから追加 ****
        
        'あみだくじ実行
        Call amidaDrive(True, r, c)
        
        'ゴールに "eureka!" を表示
        ' r と c は参照渡しされているため最後にいるセルの行と列に更新されています
        If .Cells(r + 1, c).Interior.Color = baseColor Then
            .Cells(r + 1, c).Value = "eureka!"
        End If
    
'**** ここまで ****    

    End With
    
End Sub

復帰処理

着色された線の色を元に戻す処理です。
線の色は A2 セルから取得しています。

Public Sub Click_復帰()
    Dim r As Long
    Dim c As Long
    Dim lastRow As Long
    Dim lastColumn As Long
    Dim lineColor As Long
    
    With wsMain
    
        'A1セルから地（背景）の色を取得
        baseColor = .Range("A1").Interior.Color
        
        'A2セルから線の色を取得
        lineColor = .Range("A2").Interior.Color
        
        'あみだの範囲を取得する
        With .UsedRange
            lastRow = .Item(.Count).Row
            lastColumn = .Item(.Count).Column
        End With
        
        For r = 2 To lastRow
            For c = 3 To lastColumn
                If .Cells(r, c).Interior.Color <> baseColor Then
                    .Cells(r, c).Interior.Color = lineColor
                End If
            Next
        Next
        
        .Rows(lastRow).ClearContents
    
    End With

End Sub

完成

ボタンを２つ作ってそれぞれに「Click_スタート」と「Click_復帰」を登録します。
これであみだくじの完成です。ぜひ動かしてみてください！

全コード（再掲）

'[標準モジュール]
Option Explicit

Dim myColor As Long         '自分の色
Dim baseColor As Long       '地（背景）セルの色

'メインのエントリポイントです。このプロシージャから実行してください。
Public Sub Click_スタート()
    Dim r As Long       '行番号
    Dim c As Long       '列番号
    Dim idx As Long     'どれを選ぶか
    
    'どれを選ぶか？
    Do
        idx = Val(InputBox("何番を選択しますか？（9で終了）"))
        
        '入力された数字から該当の列番号を計算する
        If 0 < idx And idx <= 4 Then
            c = (4 * idx) - 1
        ElseIf idx = 9 Then
            Exit Sub
        Else
            c = 0
        End If
        
'        よくわからなければこちらでも…
'        Select Case idx
'            Case 1
'                c = 3
'            Case 2
'                c = 7
'            Case 3
'                c = 11
'            Case 4
'                c = 15
'            Case 9
'                Exit Sub
'            Case Else
'                c = 0
'        End Select

    Loop Until c > 0
    
    r = 1
    
    With wsMain
    
        '自分の色を取得
        myColor = .Cells(r, c).Interior.Color
        'A1セルから地（背景）の色を取得
        baseColor = .Range("A1").Interior.Color
        
        'あみだくじ実行
        Call amidaDrive(True, r, c)
        
        'ゴールに "eureka!" を表示
        ' r と c は参照渡しされているため最後にいるセルの行と列に更新されています
        If .Cells(r + 1, c).Interior.Color = baseColor Then
            .Cells(r + 1, c).Value = "eureka!"
        End If
    
    End With
    
End Sub

'あみだくじの実行プロシージャ
'引数 <- goNext:次に行けるかどうか、r:行番号、c:列番号
'戻り値 -> 次に行けたかどうか
Private Function amidaDrive(ByRef goNext As Boolean, ByRef r As Long, ByRef c As Long) As Boolean

    If Not goNext Then
        '次に行けてなければそのまま goNext を返す（goNext は False になっています）
        amidaDrive = goNext
        '（amidaDrive = False のほうが直感的にわかりやすいかも）
    Else
    
        With wsMain
    
            '動きをわかりやすくするためのウェイト
            Application.Wait [Now()+"00:00:00.2"]
            
            '自分のいるセルを自分の色で着色する
            .Cells(r, c).Interior.Color = myColor
            
            '次に行けるかどうかを判定（この時点では goNext は True で渡されてきています）
            If .Cells(r, c + 1).Interior.Color <> baseColor And .Cells(r, c + 1).Interior.Color <> myColor Then
                '右のセルの色が、地の色でない かつ 自分の色でない 場合（＝グレーか もしくは 自分以外のプレイヤーの色 の場合）は右に行く
                c = c + 1
            ElseIf .Cells(r, c - 1).Interior.Color <> baseColor And .Cells(r, c - 1).Interior.Color <> myColor Then
                '右に行けなかった場合で、左のセルの色が、地の色でない かつ 自分の色でない 場合は左に行く
                c = c - 1
            ElseIf .Cells(r + 1, c).Interior.Color <> baseColor And .Cells(r + 1, c).Interior.Color <> myColor Then
                '右にも左にも行けなかった場合で、下のセルの色が、地の色でない かつ 自分の色でない 場合は下に行く
                r = r + 1
            Else
                '右にも左にも下にも行けない場合は次には行けないので goNext に False をセット
                goNext = False
            End If
        
            '上記の判定処理を元に自プロシージャを再帰呼び出し
            amidaDrive = amidaDrive(goNext, r, c)
        
        End With
    
    End If
    
End Function

Public Sub Click_復帰()
    Dim r As Long
    Dim c As Long
    Dim lastRow As Long
    Dim lastColumn As Long
    Dim lineColor As Long
    
    With wsMain
    
        'A1セルから地（背景）の色を取得
        baseColor = .Range("A1").Interior.Color
        
        'A2セルから線の色を取得
        lineColor = .Range("A2").Interior.Color
        
        'あみだの範囲を取得する
        With .UsedRange
            lastRow = .Item(.Count).Row
            lastColumn = .Item(.Count).Column
        End With
        
        For r = 2 To lastRow
            For c = 3 To lastColumn
                If .Cells(r, c).Interior.Color <> baseColor Then
                    .Cells(r, c).Interior.Color = lineColor
                End If
            Next
        Next
        
        .Rows(lastRow).ClearContents
    
    End With

End Sub