Excelマクロ（VBA）といえば「オフィスワークの手作業を自動化するもの」というイメージが強いですね。
『作業を効率化できるのはうれしい！』
『残業が減って早く帰れるのもうれしい！』
でも、なんかそれだけじゃもの足りない・・・
VBAで遊んでみましょう！
Contents
アニメーションマクロその1
まずはこちらをご覧ください
このアニメーションマクロは、仕事でもよく使うおなじみのステートメント・メソッド・関数で作っています。
- Do～Loopステートメント
- Select Caseステートメント
- Copyメソッド
- Sleep関数
※Sleep関数とは
指定の時間（ミリ秒）処理を中断する関数です。
モジュールの宣言セクションにお決まりのフレーズを記述することで使用できます。
Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
処理を１秒中断させたいときはSleep 1000と書きます。
アニメーションマクロの作り方
Excelの事前設定
①Excelシートの行と列を同じ幅に設定して、方眼紙のようにします。
（この記事の場合は行列それぞれ20ポイントに設定しています。）
②オプションでR1C1形式に設定。
「ファイル」タブをクリック→「オプション」をクリック
「数式」→「R1C1参照形式を使用する」にチェックを入れる
シートの列番号が数値で表示されるので、列番号が確認しやすくなります。
Excelシート上に画像を準備
シート名を「オリジナル画像」という名前に変更。
動きをつけるため、２パターンの絵を用意します。
パターン１→パターン２→パターン１→・・・と、２つの画像を交互に表示することで動きをつけるパラパラ漫画のような仕組みです。
※画像の赤枠線は、Rangeオブジェクトに格納する範囲です
マクロ実行用シートの準備
「オリジナル画像」シートとは別にマクロ実行用のシートを用意して下記２点の準備をします。
- 方眼紙形式（行列の幅をオリジナル画像シートと同じ設定にする）
- セルをすべて黒色で塗りつぶし
ソースコード
標準モジュールに貼り付けて使用してください。
|
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 |
Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long) Sub 画像アニメーション() Dim sh As Worksheet Set sh = Sheets("オリジナル画像") Dim Pattern1 As Range '画像パターン1 Set Pattern1 = Range(sh.Cells(2, 2), sh.Cells(11, 15)) Dim Pattern2 As Range '画像パターン2 Set Pattern2 = Range(sh.Cells(2, 18), sh.Cells(11, 31)) 'スタート位置の設定 Dim r1 As Long, c1 As Long r1 = 2: c1 = 2 Do Until c1 = 20 Select Case c1 Mod 2 Case 0 '偶数列の場合、画像パターン1を表示する Pattern1.Copy Destination:=Cells(r1, c1) Case 1 '奇数列の場合、画像パターン2を表示する Pattern2.Copy Destination:=Cells(r1, c1) End Select c1 = c1 + 1 '表示列を右へ Sleep 200 '描画間隔の設定 DoEvents Loop End Sub |
ポイント
画像範囲をRangeオブジェクトにセットする処理（Set Pattern1 = ~~）で、画像範囲よりも一回り（一行・一列）バッファを持たせて格納するのがポイントです。
下記の水色枠のように、画像サイズピッタリでRangeオブジェクトにセットすると、
マクロを動かしたときに、自らの残像が残ってしまうのです・・・
一回り余分に持たせることで、上下左右どの方向に移動しても、自らの残像を上書きしながらキレイに描画できるんですよ。
VBAっておもしろいですね！
アニメーションマクロその２
画像の準備
これも、２パターンの絵を作成します。（これが一番大変！）
※画像の赤枠線は、Rangeオブジェクトに格納する範囲です
アニメ２のソースコード
|
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 |
Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long) Dim r As Long, c As Long '画像の座標 Dim Pattern1 As Range '画像パターン1 Dim Pattern2 As Range '画像パターン2 Sub アニメーションマクロ() Dim ws As Worksheet Set ws = Sheets("オリジナル画像") '３行ずつ下に降りていくので、画像を上書きできるよう余分にセットしている Set Pattern1 = Range(ws.Cells(2, 2), ws.Cells(65, 15)) Set Pattern2 = Range(ws.Cells(2, 18), ws.Cells(65, 31)) r = 10: c = 10 'スタート位置 Dim interval As Long '画像同士の間隔設定 interval = 17 Dim imagecnt As Long '画像数（0～xまで） imagecnt = 9 Dim movecnt As Long '左右の移動回数 Dim i As Long '左右の往復回数 For i = 1 To 2 ' ---------移動開始-------------- Do Until movecnt = 10 '右への移動回数 Call 画像移動(interval, imagecnt) c = c + 1 '次の画像コピー先を1列右へ移動 movecnt = movecnt + 1 Sleep 100 DoEvents Loop r = r + 3 '3行下へ移動 c = c - 1 '１列左へ移動 Do Until movecnt = 0 '右へ移動した回数分、左に戻る Call 画像移動(interval, imagecnt) c = c - 1 '次の画像コピー先を1列左へ移動 movecnt = movecnt - 1 '移動回数 Sleep 100 DoEvents Loop r = r + 3 '3行下へ移動 c = c + 1 '1列右へ移動 Next i End Sub Sub 画像移動(ByVal interval As Long, imagecnt As Long) Dim n As Long '※For文で１オブジェクトずつコピーするためいったん画面更新を止める Application.ScreenUpdating = False Select Case c Mod 2 Case 0 '偶数列の場合、画像パターン1を表示する For n = 0 To imagecnt Pattern1.Copy Destination:=Cells(r, c + interval * n) Next n Case 1 '奇数列の場合、画像パターン2を表示する For n = 0 To imagecnt Pattern2.Copy Destination:=Cells(r, c + interval * n) Next n End Select '画面更新を再開 Application.ScreenUpdating = True End Sub |
アニメの解説
こんな風に動いています。
画面更新・停止処理
１つの画像Rangeを合計10個、１RangeずつFor～Next文でコピー貼り付けしています。
そのため、画面更新したままでは各オブジェクトのコピー貼り付けに若干のタイムラグが発生してアニメーションが美しくないのです。
そこで、画面更新をいったん止めてから、
Application.ScreenUpdating = False
画像Range×10をコピー貼り付けして、
画面更新を再開する（アニメーション再開）
Application.ScreenUpdating = True
という流れにしています。
画像のコピー貼り付け
コピー貼り付け処理のコードがこちらです。
|
1 2 3 |
For n = 0 To imagecnt Pattern1.Copy Destination:=Cells(r, c + interval * n) Next n |
貼り付け先の列番号を示すc + interval * nがちょっと難しいですね。
このような仕組みで全10個の画像Rangeを配置しています。
（参考）
