モジュールレベル変数（コロ子勘違いしていた）
こんにちは。
派犬事務員のコロ子です。
前回記事で自動採番のマクロを作成。
データの保持が上手くできず、空いているセルに仮置きする方法で作成した。
何かもっと良い方法はないのかなぁ～と聞いてみたところ、空腹おやじ(id:Z1000S)さんからこんな方法が！！↓ (素晴らしいので必見)
コードを見て「えっつ！」と。コロ子が空いているセルに仮置きしたデータをモジュールレベル変数に入れている。？？？と思い実際やってみたところ、コロ子ずっと勘違いしてた事が判明。（注）低レベルです。
モジュールレベル変数
何を勘違いしていたかというと、一つのプロシージャが終了したら「全ての変数が破棄される」と思っていた。
【モジュールレベル変数】
変数をモジュールの最上部で、どこのプロシージャにも属さないで宣言すると、プロシージャ間で共有して使用できる。
Private buf As Long ’**************************************** Sub test1() End Sub ’**************************************** Sub test2() End Sub
この場合だと、変数「buf」はプロシージャ「test1」と「test2」で共有して使用できる。
ここまでは、コロ子も認識していた。
【コロ子の勘違い】
Private buf As Long ’**************************************** Sub test1() buf = 1 End Sub ’**************************************** Sub test2() Debug.Print buf End Sub
上記の場合で
①「test1」を実行する
②「test2」を実行する
一つのプロシージャが終了したら「全ての変数が破棄される」と思っていたので、この場合「test2」の「buf」には「初期値の0」が入っていると思っていた。
実際は値は保持されていて
「test2」の「buf」には「1」が入っている。
えーーーー！そうなの？
コロ子ずーっと勘違いしてた。
そうとは知らず、今までかなりムダに苦戦してきた。
これができるとなるとコードの書き方の考え方が変わる。
目から鱗！！
ちなみに、今までどうやってモジュールレベル変数を使っていたかというと
Private buf1 As Long Private buf2 As Long ’**************************************** Sub test1() buf1 = 1 buf2 = 2 Call test2 End Sub ’**************************************** Sub test2() buf1 = 10 Call test3 End Sub ’**************************************** Sub test3() Debug.Print buf1 Debug.Print buf2 End Sub
引数を渡すのが面倒なとき。
「test2」で「buf2」は必要ないけど、「test2」で呼び出してる「test3」では「buf1」も「buf2」も必要なとき。
引数がたくさんあって、受け渡しがごちゃごちゃのときに使う物だと思っていた。
もしかしたらこの考え方も違うのかも・・・。
今回、空腹おやじさんに教えてもらわなかったら、この先もずーーーっと勘違いしたままだった。本当に、本当に感謝です。
ありがとうございました。
Worksheet_ChangeイベントとWorksheet_SelectionChangeイベント（前回の種目の自動採番コード変更しました）
こんにちは。
派犬事務員のコロ子です。
前回の記事、種目別の自動採番のコードで
空腹おやじ(id:Z1000S)さんより、
この処理だと、登録済みのA列のセルで、B列の値が最大値ではない行でF2を押して編集状態にして、そのまま何も変えないでEnter押しちゃうと、B列の値が更新されちゃいますが、大丈夫ですか？（F2、Escだと大丈夫ですが）
とご指摘頂きました。
おおっつ！ヤバイ！大丈夫じゃない！
そこまで考えが至らなかった。
下記の図のように、もうすでに値が入っているA列を編集状態にする。
↓
値を変更しないで確定すると最大値＋1を採番してしまう。
これは良くない！！重大なバグ！
実はコロ子の会社で作ったマクロはB列でダブルクリックすると採番するよういしていて、ブログ用にちょっとアレンジしたら、この有様。
（会社で問題なく使えてるから安心して！）
更新したくないのであれば、SelectionChangeイベントで、変更前の値を保持しておいて、Changeイベントで変更されているか確認する等、なんらかの処理が必要になるかも。by空腹おやじ(id:Z1000S)さん
とアドバイスいただいたので、早速作り直さなければ！
前回書いたダメなコード（コピー不可）
Private Sub Worksheet_Change(ByVal Target As Range)
Dim buf As Range
Application.ScreenUpdating = False
'1列目（A列）に変更があった時
If Target.Column = 1 Then
'初期化
Range("B" & Target.Row).Value = ""
'A列でフィルタ
Range("A1").AutoFilter Field:=1, Criteria1:=Range("A" & Target.Row).Value
'アクティブセル領域の可視範囲を取得
Set buf = Range("A1").CurrentRegion.Columns(2).SpecialCells(xlCellTypeVisible)
'最大値＋1を取得
Range("B" & Target.Row).Value = Application.WorksheetFunction.Max(buf) + 1
'フィルター条件解除
ActiveSheet.ShowAllData
End If
Application.ScreenUpdating = True
End Sub
＊前回記事のコードは修正しました。
何がダメかというと、 Worksheet_Changeイベントについて分かっていない。
Worksheet_Changeイベント
イベントの名前が「Change」なのでセルに値や数式を入力したり、入力されているデータを変更した時に発生するイベントだと思っていた。
Changeイベントは、名前に騙されやすいので要注意です。
by空腹おやじ(id:Z1000S)さん
ところが入力されているデータを変更しなくても「編集状態」にして「確定」すると変更したとみなされ、イベントが発生してしまう。
知らなかった～。これ危険だわー。
＊「編集状態」にしてもescキーでキャンセルすればイベントは発生しない。
また、セルに色を付けたり、書式などの変更でもイベントは発生しない。
Worksheet_SelectionChangeイベント
イベントの名前の通り、選択セルが変更されたらイベントが発生する。
引数Targetに変更後のセル（カーソルがあるセル）のRangeオブジェクトが取得できる。
考え方
ChangeイベントとSelectionChangeイベントのダブル使い。
①A列のセルにカーソルが移動したら、Worksheet_SelectionChangeイベントでカーソルのあるセルの値と、の隣のB列の値を空いてるセルに仮置きする。
A列の値をAA列、B列の値をBB列に入力。
②そのセルでChangeイベントが発生したら、採番し隣のB列に値を入れる。
③もし、Changeイベント発生時のA列の値と、保存してあるAA列の値が同じ場合は、保存しているBB列の値をB列に入れる。
【コード】Worksheet_SelectionChangeイベント
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Target.Column = 1 And Target.Row >= 2 Then
'AA列、BB列に仮置き
Range("AA:BB").Clear
Range("BB" & Target.Row).Value = Range("B" & Target.Row).Value
Range("AA" & Target.Row).Value = Range("A" & Target.Row).Value
End If
End Sub
【コード】Worksheet_Changeイベント
Private Sub Worksheet_Change(ByVal Target As Range)
Dim buf As Range
Application.ScreenUpdating = False
Application.EnableEvents = False 'イベント禁止
If Target.Column = 1 Then
'オートフィルタ
Range("A1").AutoFilter Field:=1, Criteria1:=Range("A" & Target.Row).Value
'アクティブセル領域の可視範囲を取得
Set buf = Range("A1").CurrentRegion.Columns(2).SpecialCells(xlCellTypeVisible)
'最大値＋1を取得
Range("B" & Target.Row).Value = Application.WorksheetFunction.Max(buf) + 1
'フィルター条件解除
ActiveSheet.ShowAllData
'A列に変更がない場合は元の値に戻す
If Range("A" & Target.Row).Value = Range("AA" & Target.Row).Value Then
Range("B" & Target.Row).Value = Range("BB" & Target.Row).Value
End If
'AA列、BB列に仮置き
Range("AA:BB").Clear
Range("BB" & Target.Row).Value = Range("B" & Target.Row).Value
Range("AA" & Target.Row).Value = Range("A" & Target.Row).Value
End If
Application.ScreenUpdating = True
Application.EnableEvents = True
End Sub「Worksheet_SelectionChangeイベントで変更前の値を保持しておいく」のところを静的変数Staticを使おうとしたけど、モジュール変数として使う事がでなかった。
「プローシシャーの外では使えません」のエラーメッセージが出た。
結局上手くできず、いつもの仮置き方式。
仮置き方式でないなら、どのように作るものなのでしょうか・・・？
今回は空腹おやじ(id:Z1000S)さんのアイディアをそのまま使わせて頂きました。
どうもありがとうございました！
Excel VBA 種目別に自動採番（複数の種類で連番を取る）
こんにちは。
派犬事務員のコロ子です。
種目別自動採番マクロ
コロ子の会社では毎日、品物が増えるたびに連続の番号を取る作業ある。
A列に複数の種類が入っていて、種類ごとに連番を取る。
【例】下記表で新しく種目CCCが追加になる場合。
B列に66を入力する。
もし
AAAなら：103
BBBなら：22
DDDなら：33
こんな具合に採番をする。手作業なら多分、A列の項目でフィルタをして、B列の最大値に1を足した数値を入力する。
途中で種目が変更になったり、欠番が出たり、B列の最大値が一番下に来ているとは限らない場合があるので地味に面倒な作業だったりする。
こんな作業を毎日やっているならば、マクロを作成しよう。
コピペでできるよ！
作り方
【① A列に入力規則を作成する。】
（プルダウンでデータを選択できるようにする）
A列を選択した状態で、「データ」タブ→「データの入力規則」→「データの入力規則」を選択
入力の種類：「リスト」を選択
元の値：種目を半角カンマ（,）で区切って入力
【② コードをシートモジュールに書く】
対象のシート（ここではSheet1）のシートモジュールを選択する。
オブジェクトボックスで「WorkSheet」、プロシージャーボックスで「Change」を選択する。
コードウィンドウに下記コードを書く
＊Private Sub Worksheet_Change(ByVal Target As Range)はプロシージャーボックスで「Change」を選ぶと自動に表示される。
セルの中身を変更したらこのプロシージャーが呼び出される。
【コード】Worksheet_Changeイベント
Private Sub Worksheet_Change(ByVal Target As Range)
Dim buf As Range
Application.ScreenUpdating = False
Application.EnableEvents = False 'イベント禁止
If Target.Column = 1 Then
'オートフィルタ
Range("A1").AutoFilter Field:=1, Criteria1:=Range("A" & Target.Row).Value
'アクティブセル領域の可視範囲を取得
Set buf = Range("A1").CurrentRegion.Columns(2).SpecialCells(xlCellTypeVisible)
'最大値＋1を取得
Range("B" & Target.Row).Value = Application.WorksheetFunction.Max(buf) + 1
'フィルター条件解除
ActiveSheet.ShowAllData
'A列に変更がない場合は元の値に戻す
If Range("A" & Target.Row).Value = Range("AA" & Target.Row).Value Then
Range("B" & Target.Row).Value = Range("BB" & Target.Row).Value
End If
'AA列、BB列に仮置き
Range("AA:BB").Clear
Range("BB" & Target.Row).Value = Range("B" & Target.Row).Value
Range("AA" & Target.Row).Value = Range("A" & Target.Row).Value
End If
Application.ScreenUpdating = True
Application.EnableEvents = True
End Sub
同様にプロシージャーボックスで「SelectionChange」を選択し、下記のコードを書く。
（登録済みのA列を編集状態にして、変更しないでEnter押した場合、値が変更されるのを防ぐため）
【コード】Worksheet_SelectionChangeイベント
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Target.Column = 1 And Target.Row >= 2 Then
'AA列、BB列に仮置き
Range("AA:BB").Clear
Range("BB" & Target.Row).Value = Range("B" & Target.Row).Value
Range("AA" & Target.Row).Value = Range("A" & Target.Row).Value
End If
End Sub
＊空腹おやじ(id:Z1000S)さんよりご指摘頂いて修正しました。
詳しくは次の記事で。
完成！
例えば、A列に日付、B列に種目、C列に番号の表の場合、コードの
”A”→”B”
”B”→”C”
”A1”→”B1”
4行目のTarget.Column = 1 → Target.Column = 2（数字は列の番号）
に変更すればOK！
こんな作業のある人は自分の表に合わせて作ってみよう！
このマクロ、VBAを始めたての頃に「マクロの自動記録」で作成した。
もちろんそのままでは使えないから、上手くいかないところを無理やり手で直して、何がなんだか分からないけど、とりあえず希望の結果になるからOKという作り方だった。
それから毎日このマクロを使っていて、特に問題ないからずっとそのままにしてたけど、最近見直したら、あまりにもヒドイ驚きのコードだったので作り直すことにした。マクロの自動記録をベースにしてるからコードがやたらと長くて意味不明の個所がいっぱいあった。
そんなデタラメでも、出来た時は感動したし、すごく便利で重宝しているから、下手でも力ずくでも作って良かっな、って思う。そして、その時の感動が「VBAでもっといろいろできるようになりたい！」という気持ちの源だったんだな、と実感。
マンゴー杯！
こんにちは。
派犬事務員のコロ子です。
マンゴー杯 結果報告
前回、あみだくじや抽選のコードを「自分ならこう書く！」を募集したところ、素晴らしいアイディアの応募がありました！どうもありがとうございます！！
みんな演出が凝っていて高度な技が満載！
エントリーNo.１
セラエノ (id:celaeno42)さん
celaeno42.hatenablog.com
エントリーNo.２
id:Infomentさん
infoment.hatenablog.com
さらに進化版。あみだくじの格子部分もマクロで作る↓
infoment.hatenablog.com
すごい！！！
あみだくじの完成形。必見↓
infoment.hatenablog.com
あみだくじファイナル↓
infoment.hatenablog.com
エントリーNo.3
Kou (id:ExcelLover)さん
www.excellovers.com
エントリーNo.4
コロ子
ちょっとみんな凄すぎて実力の差がありすぎる・・・。
こうなったらコロ子が絶対当たるマクロを作ろう。
【コロ子が絶対当たる抽選】
マンゴーの数を入力して「抽選」ボタンを押すと、「当たり」「はずれ」が表示される。コロ子は絶対「当たり」が出る。
【考え方】
①「当たり・はずれの要素」「乱数を入れる要素」を加者数-1（コロ子を抜かす）の要素数の2次元配列を用意する。
②「当たり・はずれの要素」の先頭から、マンゴーの数-1個の当たり、後ははずれを入れる。
③「乱数を入れる要素」に整数1～参加者数を重複しないでランダムに入れる。
例：マンゴーの数3個、コロ子以外の参加者7人の場合の配列のイメージ
④「乱数を入れる要素」で昇順にソートする。
⑤結果セルに「乱数を入れる要素」を順に入れていく。
このとき参加者が「コロ子」だったら当たりを入れスキップし、次のセルへ。
【コード】
抽選ボタン
Sub Absolutely_win()
Dim i As Long, j As Long
Dim StartCell As Long
Dim Cellcount As Long
Dim Arr() As Variant
Application.ScreenUpdating = False
StartCell = 5
Cellcount = Cells(Rows.Count, 1).End(xlUp).Row - StartCell
ReDim Arr(1 To Cellcount, 1)
For i = 1 To Cellcount
If i < Range("B2").Value Then
Arr(i, 0) = "当たり"
Else
Arr(i, 0) = "はずれ"
End If
Dim Flg() As Boolean
ReDim Flg(1 To Cellcount)
Dim Num As Long
'整数1～参加者数を重複しないでランダムに発生させる
Randomize
Do
Num = Int((Cellcount - 1 + 1) * Rnd + 1)
Loop Until Flg(Num) = False
Arr(i, 1) = Num
Flg(Num) = True
Next i
'ソート
Call ArrSort(Arr)
'セルに配列を入れる（コロ子の時は当たりを入れる）
For i = 1 To Cellcount
Cells(StartCell, 2).Value = Arr(i, 0)
If Cells(StartCell, 1).Value = "コロ子" Then
Cells(StartCell, 2).Value = "当たり"
i = i - 1
End If
StartCell = StartCell + 1
Next i
Application.ScreenUpdating = True
End Sub※範囲を指定して乱数を発生させる
乱数=Int((最大値 - 最小値 +1 ) * Rnd + 最小値)
配列をソートする
Sub ArrSort(Arr As Variant)
Dim bufL As Long
Dim bufS As String
Dim i As Double
Dim j As Double
For i = UBound(Arr, 1) To LBound(Arr, 1) Step -1
For j = LBound(Arr, 1) To i - 1
If Arr(j, 1) > Arr(j + 1, 1) Then
bufS = Arr(j, 0)
bufL = Arr(j, 1)
Arr(j, 0) = Arr(j + 1, 0)
Arr(j, 1) = Arr(j + 1, 1)
Arr(j + 1, 0) = bufS
Arr(j + 1, 1) = bufL
End If
Next j
Next iやったー！コロ子マンゴー当たったー！！
セコイ！！
こーゆー不正はダメですよ！
【今回のポイント】
整数1～参加者数を重複しないでランダムに発生させる
For i = 1 To Cellcount
・
・
・
Dim Flg() As Boolean
ReDim Flg(1 To Cellcount)
Dim Num As Long
Randomize
Do
Num = Int((Cellcount - 1 + 1) * Rnd + 1)
Loop Until Flg(Num) = False
Arr(i, 1) = Num
Flg(Num) = True
Next iBoolean型の初期値はFalse
範囲を指定して乱数を発生させてみたら、意外と多く重複していた。
重複しないように作ろうとしたところ、なかなか上手かず、ネットで調べたら
Boolean型の配列を使うというのがあった。
最初Do～Loopのところだけを見て？って思ったけど、その下の
Arr(i, 1) = Num
Flg(Num) = True
を見て納得！Boolean型の初期値はFalse。Numを配列に格納したらFlgの要素数Num番目をTrueにすれば、ループでフラグの要素数Num番目がTrueだったら重複しているので、重複しなくなるまで乱数を発生させる。
こんなフラグの使い方あるんだ！
参考サイト
www.moug.net
マクロを作ると本質が見える？
こんにちは。
派犬事務員のコロ子です。
前回からExcel VBAであみだくじを作成中。
【前回の記事】
①派遣事務 特殊スキルは評価されにくい - 派遣事務員の迷走
②VBAで「あみだくじ」を作ろう。 - 派遣事務員の迷走
③使えないマクロにならないために - 派遣事務員の迷走
前回、あみだくじの結果が一瞬で分かるコードを書いていて思ったんだけど・・・。
ここまで来ると、そもそも「あみだくじ」の必要があるのかどうか。
「じゃんけん」でも、「あたり・はずれを書いた紙を箱に入れてくじ引きする」、でも何でも良かったと思う。
30人中、17人にマンゴーが当たる。
これを満たせば何でも良かった。
ただ、「じゃんけん」だとなかなか勝負がつかないし、「くじ引き」だと、くじを引く順番で公平さが損なわれる。
だから手っ取り早く「あみだくじ」にしただけであって、何でも良かった。
と言うことは、こんな感じで良くない？
マンゴーの数を入力して
「抽選ボタン」を押す。
↓
マンゴーの数だけ当たりがランダムにでる。
乱数を使えば公平だよね？
【考え方】
マンゴーの数3個でやってみる。
①まず、B列に上からマンゴーの数だけ「当たり」を入れ、それ以降には「はずれ」を入れる。
②乱数を発生させC列に仮置きする。
B列とC列を対象にC列で昇順にソートする。
仮置きしていたC列を削除すれば、ランダムに当たりが出た事になる。
コード
Sub Lottery()
Dim i As Long
Dim StartCell As Long
Dim EndCell As Long
Application.ScreenUpdating = False
StartCell = 5
EndCell = Cells(Rows.Count, 1).End(xlUp).Row
For i = StartCell To EndCell
If i - StartCell < Range("B2").Value Then
Cells(i, "B").Value = "当たり"
Else
Cells(i, "B").Value = "はずれ"
End If
'乱数を発生させ、C列に仮置き
Randomize
Cells(i, "C").Value = Rnd
Next i
'乱数入れたC列でソートする
Range("B" & StartCell & ":C" & EndCell).Sort Key1:=Range("C4"), Order1:=xlAscending
'C列をクリア
Range("C" & StartCell & ":C" & EndCell).Clear
Application.ScreenUpdating = True
End Sub
感想
今回VBAであみだくじを作っていたら、「そもそもあみだくじにする意味あるのかな？公平なら何でも良くない？」と疑問が沸いた。
業務でも、こういうのいっぱいあると思う。
そもそも、何の為にそれをやるのか。
今までは手作業だったからそのやり方が最善だったけど、本当は何がしたいのか。
マクロを作っていると、本当はどうなんだろう？って思ってくる。
例えば、マンゴーを貰える人を選出する業務があるとして（何のこっちゃ）、毎日あみだくじをやっていたとする。
派犬のコロ子が「あみだくじの意味はありますか？抽選で良くないですか？」なんて言ったところで、「業務規定ではあみだくじで選出することになっています。なので簡単にあみだくじができるツールを作成してください。」と言われてしまう。
働き方改革、業務改善、本当に見直さなければいけないところはどこなんだろう・・・？
社内規定、業務規定の前にして派犬の無力さ（限界）を感じる・・・
お知らせ
今回の抽選のマクロ、コロ子は間借り方式で作ったけど、こういうのの考え方は人それぞれ。
「自分ならこうする！」と言うのがあれば、ぜひコメントください！
ブログ、Twitter＠2a9SouLnhptnIqGで随時募集してます。
もちろん「あみだくじ」の書き方も募集してます！
自分が絶対当たるようにしちゃうとか（不正）もありです。
セラエノ (id:celaeno42)さんのあみだくじ。説明が分かりやすい！
動くのが見えるから楽しい！
celaeno42.hatenablog.com
使えないマクロにならないために
こんにちは。
派犬事務員のコロ子です。
【前回の記事】
① 派遣事務 特殊スキルは評価されにくい - 派遣事務員の迷走
② VBAで「あみだくじ」を作ろう。 - 派遣事務員の迷走
紙に書いたあみだくじは、「あみだくじ～」って歌いながらやるから楽しいけど、マクロで動かすと、とたんにつまらなくなる。
紙のあみだくじより速いし手間もかからないのに、人数分の回数（30回）スタートボタンとクリアボタン交互に押すのは超面倒と感じるようになる。
おそらく、業務でも同じような事は多々あると思う。
手でやるより早いのに「何か面倒、使えないマクロ」とか言わる事はないだろうか・・・？
そこで、使えない、と思われないためにこんなのはどうだろう？
スタートボタンを押す
↓
結果が表示される
どうせつまらないなら早く結果を知りたいよね？それが人（犬）。
30人用のあみだくじだと、30行以上ないと公平性が保てない気がするので、何人でも、何行でもOKのコードに変更してみた。縦線・横線を自由に増やしてOK。
コード
スタートボタン
結果をあみだくじ最終行の下に書き込みながら人数分ループする。
Dim result As String
Dim LastRow As Long
Sub Start()
Dim c As Long
Dim ran As Range
Application.ScreenUpdating = False
Call Reset '結果のクリア＆最終行取得
For c = 1 To Cells(3, Columns.Count).End(xlToLeft).Column
Set ran = Cells(3, c).Offset(1, 0)
Call Rigth_Cell(ran)
Cells(LastRow + 2, c).Value = Cells(3, c).Value
Cells(LastRow + 3, c).Value = result
Next c
Set ran = Nothing
Call undo
Application.ScreenUpdating = True
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
'結果を取得する（★ここを追加した）
If ran.Row = LastRow - 1 Then
result = ran.Offset(1, 0).Value
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
'結果を取得する（★ここを追加した）
If ran.Row = LastRow - 1 Then
result = ran.Offset(1, -1).Value
End If
Wend
End Sub
クリアボタン（結果を削除する）
クリアボタンを押したときと、マクロの最初に呼び出して、クリア＆最終行取得
Sub Reset()
LastRow = Cells(Rows.Count, 1).End(xlUp).Row
With Cells(LastRow - 1, 1)
If .Borders(xlEdgeLeft).LineStyle <> xlContinuous And _
.Borders(xlEdgeRight).LineStyle <> xlContinuous Then
Range(LastRow - 1 & ":" & LastRow).Delete
LastRow = LastRow - 3
End If
End With
End Sub
赤線を黒に戻す（前回のまま）
前回はクリアボタンに充てていたけど、今回はマクロの最後に1回呼び出せばOK。
Sub undo()
Dim ran As Range
For Each ran In ActiveSheet.UsedRange '.CurrentRegion
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どんなに大きなあみだくじでもスタートボタンを押すだけで一瞬で結果が分かる。
あみだくじの楽しさはゼロだけど、一瞬だから逆に楽しい。
業務でもこれくらい一瞬なら使った人に「楽しい！」って思われる。
もう使えないマクロとは言わせない！
でも、マクロを作ってる時に思った事があるんだけど・・・。
つづく。
【次の記事】
マクロを作ると本質が見える？ - 派遣事務員の迷走
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回）スタートボタンとクリアボタン交互に押すの面倒・・・。
つづく
【次の記事】
使えないマクロにならないために - 派遣事務員の迷走
