派遣事務員の迷走

派遣事務員コロ子。会社の犬。顔出しNG。常に迷走している。

VBAで「あみだくじ」を作ろう。

こんにちは。
派犬事務員のコロ子です。

前回、マンゴー争奪戦を行った「あみだくじ」をExcel VBAで作ってみた。
得意な事は面倒とか大変とか思わないはず!
得意と言えるレベルではないけど、面倒じゃなかった。(ギリギリ)

【前回記事】
派遣事務 特殊スキルは評価されにくい - 派遣事務員の迷走

あみだくじを作ろう

まずは罫線を使ってあみだくじを作る。
縦の罫線を引いて、適当に横の罫線を引く。


f:id:SNegishi:20190726062656p:plain

くじをやりたい人にカーソルを置いて「スタート」ボタンを押す。
          

f:id:SNegishi:20190724193809p:plain


考え方

たどる線の分岐のパターンを分ける。

【①セルの右側の縦線をたどる場合】

①-1 左下に線がある場合
右線と下線を赤色に変更して、下に1つセルを移動する → 左側の縦線をたどる(②へ)
f:id:SNegishi:20190724223019p:plain

①-2 右下に線がある場合
右線と右隣セルの下線を赤色に変更して、右に1つ、下に1つセルを移動する
f:id:SNegishi:20190724222955p:plain

①-3 下線がない場合
右線を赤色に変更して下に1つセルを移動する。
f:id:SNegishi:20190724225532p:plain



【②セルの左側の縦線をたどる場合】

②-1 右下に線がある場合
左線と下線を赤色に変更して、下に1つセルを移動する → 右側の縦線をたどる(①へ)
f:id:SNegishi:20190724225935p:plain

②-2 左下に線がある場合
左線と左隣セルの下線を赤色に変更して、左に1つ、下に1つセルを移動する
f:id:SNegishi:20190724230117p:plain

②-3 下線がない場合
左線を赤色に変更して下に1つセルを移動する。
f:id:SNegishi:20190724230228p:plain

分岐は左右、3パターンずつ。
左右それぞれのプロシージャーを作成する。
たどる線がセルの反対側に移ったときに反対側のプロシージャーを呼び出す。
これをあみだくじの最後の行までループする。

【コード】

スタートボタン
カーソルを置いたセルの1つ下のセルの右側の線からスタート

Const LASTROW = 12

Sub Start()

Dim ran As Range

Set ran = ActiveCell.Offset(1, 0)
Call Rigth_Cell(ran)
Set ran = Nothing

End Sub


セルの右側をたどる

Sub Rigth_Cell(ran As Range)

While ran.Row < LASTROW

    '①-1 左下に線がある場合
    If ran.Borders(xlEdgeBottom).LineStyle = xlContinuous Then
    
        ran.Borders(xlEdgeRight).Color = RGB(255, 0, 0)
        ran.Borders(xlEdgeBottom).Color = RGB(255, 0, 0)
        Set ran = ran.Offset(1, 0)
        Call Left_Cell(ran) 'だどる線をのセル左側に変更する
        
    '①-2 右下に線がある場合
    ElseIf ran.Offset(0, 1).Borders(xlEdgeBottom).LineStyle = xlContinuous Then
    
        ran.Borders(xlEdgeRight).Color = RGB(255, 0, 0)
        ran.Offset(0, 1).Borders(xlEdgeBottom).Color = RGB(255, 0, 0)
        Set ran = ran.Offset(1, 1)

    '①-3 下線がない場合
    Else

        ran.Borders(xlEdgeRight).Color = RGB(255, 0, 0)
        Set ran = ran.Offset(1, 0)
        
    End If

Wend

End Sub


セルの左側をたどる

Sub Left_Cell(ran As Range)

While ran.Row < LASTROW

    '②-1 右下に線がある場合
    If ran.Borders(xlEdgeBottom).LineStyle = xlContinuous Then
    
        ran.Borders(xlEdgeLeft).Color = RGB(255, 0, 0)
        ran.Borders(xlEdgeBottom).Color = RGB(255, 0, 0)
        Set ran = ran.Offset(1, 0)
        Call Rigth_Cell(ran)    ’だどる線をのセル右側に変更する
    
    '②-2 左下に線がある場合
    ElseIf ran.Offset(0, -1).Borders(xlEdgeBottom).LineStyle = xlContinuous Then
        
        ran.Borders(xlEdgeLeft).Color = RGB(255, 0, 0)
        ran.Offset(0, -1).Borders(xlEdgeBottom).Color = RGB(255, 0, 0)
        Set ran = ran.Offset(1, -1)
        
    '②-3 下線がない場合
    Else
        ran.Borders(xlEdgeLeft).Color = RGB(255, 0, 0)
        Set ran = ran.Offset(1, 0)
        
    End If
    
Wend

End Sub


クリアボタン
赤線を黒線に戻す

Sub undo()

Dim ran As Range

For Each ran In ActiveSheet.UsedRange 

    If ran.Borders(xlEdgeRight).Color = RGB(255, 0, 0) Then
        ran.Borders(xlEdgeRight).Color = RGB(0, 0, 0)
    End If

    If ran.Borders(xlEdgeLeft).Color = RGB(255, 0, 0) Then
        ran.Borders(xlEdgeLeft).Color = RGB(0, 0, 0)
    End If

    If ran.Borders(xlEdgeBottom).Color = RGB(255, 0, 0) Then
        ran.Borders(xlEdgeBottom).Color = RGB(0, 0, 0)
    End If
    
Next ran
    
End Sub

できた!

でも、紙に書いたあみだくじは、「あみだくじ~」って歌いながらやるから楽しいけど、これだと何かつまんない。
つまんない上に人数分の回数(30回)スタートボタンとクリアボタン交互に押すの面倒・・・。

つづく

【次の記事】
使えないマクロにならないために - 派遣事務員の迷走