VBAで「あみだくじ」を作ろう。
こんにちは。
派犬事務員のコロ子です。
前回、マンゴー争奪戦を行った「あみだくじ」をExcel VBAで作ってみた。
得意な事は面倒とか大変とか思わないはず!
得意と言えるレベルではないけど、面倒じゃなかった。(ギリギリ)
【前回記事】
派遣事務 特殊スキルは評価されにくい - 派遣事務員の迷走
あみだくじを作ろう
まずは罫線を使ってあみだくじを作る。
縦の罫線を引いて、適当に横の罫線を引く。
くじをやりたい人にカーソルを置いて「スタート」ボタンを押す。
↓
考え方
たどる線の分岐のパターンを分ける。
【①セルの右側の縦線をたどる場合】
①-1 左下に線がある場合
右線と下線を赤色に変更して、下に1つセルを移動する → 左側の縦線をたどる(②へ)
①-2 右下に線がある場合
右線と右隣セルの下線を赤色に変更して、右に1つ、下に1つセルを移動する
①-3 下線がない場合
右線を赤色に変更して下に1つセルを移動する。
【②セルの左側の縦線をたどる場合】
②-1 右下に線がある場合
左線と下線を赤色に変更して、下に1つセルを移動する → 右側の縦線をたどる(①へ)
②-2 左下に線がある場合
左線と左隣セルの下線を赤色に変更して、左に1つ、下に1つセルを移動する
②-3 下線がない場合
左線を赤色に変更して下に1つセルを移動する。
分岐は左右、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回)スタートボタンとクリアボタン交互に押すの面倒・・・。
つづく
【次の記事】
使えないマクロにならないために - 派遣事務員の迷走