2020/02/19

図形も貼り付けられるスケジュール帳




1.スケジュール帳作成の経緯

20年くらい前、一緒に仕事をする仲間のために「矢印や吹き出しも描けるスケジュール帳」を作りました。当時はExcel95だった気がします。結局ほとんどの人には見向きもされませんでしたが、1人だけは気に入ってくれたようで、長くずっと使ってくれていました。
今は各人がスマホを持ち、多機能なスケジュールアプリがあふれている時代です。今更このようなものは珍しくないでしょうが、Excelで図形とセルを同時に扱う難しさという点で紹介したいと思います。

2.概要と全体の流れ

図2-1の通り、スケジュール帳は一週間単位で日曜~土曜を縦に並べてあり、1日は3行にしてあります。思惑としては「午前、午後、夜」の3つに分けているつもりで、一週間21行でちょうど1画面くらいになりそう と考えました。


図2-1

スケジュール記入欄の上にスクロールバーを配置し、左右に動かすことで次週・前週などのスケジュール画面に移動することができます。
スケジュール記入欄では、セルに文字を入力するのはもちろん、色で仕訳けたり、アドレスを貼り付けたり、また画像や図形を貼り付けたりできます。なお、図形は記入範囲の太枠内に収めることを前提とし、図形がはみ出すと忠告を出します。これについては、3項で説明します。

プログラムの流れは図2-2の通りです。尚、現在表示されている画面の日付をA、次に表す画面の日付をBとしています。

図2-2

記入するのはSheet1に作ったスケジュール記入欄エリアで、そのデータを保存するのはSheet2のA列にしました。記入⇔保存は1週間単位の画面コピペで行っていますので、保存には記入欄エリアと同じ21行/週 x 保存週 を使用します。

3.メインプログラムの説明

まず、Sheet1の記入欄範囲の左側に「年・月日・曜日」が縦に並んでいますが、これは図3-1のようにワークシート関数が記入されています。セルB2の日付データ(図3-1では数式表示の為、シリアル値になっています)を元に、年・月日が計算されるようにしています。

図3-1

次に、スクロールバーの設定ですが、図3-2のように調整するのは「LargeChange」「Max」「Min」「SmallChange」「Value」の5項目です。Max・Minを ±5 にしたのは、「大きく動かしても1か月(約5週間)だろう」と考えたからです。1年先・1年前に飛びたいという要求があるようでしたら±50くらいを設定するようでしょう。尚、Value値はゼロにします。

図3-2

スケジュール帳の記入欄部分は Sheet1 に作り、マクロも Sheet1 に記載しています。
まずはメイン部分について図3-3に示し、1つ1つのコードの説明をします。そして、そのメインから呼び出されるサブプロシージャをその後の4項で説明します。
  1. '========== ⇩① 変数・定数宣言  =================
  2. Dim Bar_0 As Boolean       '←スクロールバーのValue値をゼロに戻した時の再表示を防止するフラグ
  3. Dim Memo_Range As Range     '←スケジューラ記入範囲を表すRange変数
  4. Dim Save_Top As Range      '←スケジューラを保存する位置の先頭を表すRange変数
  5. Const Start_Day As Date = #12/29/2019#   '←スケジューラの開始週(日曜日)
  6. Const End_Day As Date = #1/6/2030#     '←スケジューラの最終週(日曜日)
  7. '=========== ⇩② スケジュール記入範囲、保存範囲の設定  ===============
  8. Public Sub Range_Set()
  9.  Set Memo_Range = Sheets("sheet1").Range(Cells(3, 3), Cells(23, 3))   '←記入範囲を指定
  10.  Set Save_Top = Sheets("sheet2").Range("a1")               '←保存範囲の先頭セルを指定
  11. End Sub
  12. '============ ⇩③ スクロールバー値を変更した時に動くプロシージャ  ===========
  13. Private Sub ScrollBar1_Change()
  14.  Application.ScreenUpdating = False   '←動作速度を向上させる為、画面更新を止める
  15.  If Bar_0 = True Then Exit Sub        '←スクロールバーのValue値をゼロに戻した時には実行しない
  16.  If Memo_Range Is Nothing Then Range_Set   '←起動時にMemo_Range値が設定されていない場合は設定
  17.  If Shape_Group_XOR(Memo_Range) = 0 Then GoTo Value0  '←枠線に掛かる図形があれば中止
  18.  Dim Next_Week As Date      '←次に表示する週の初日値
  19.  Dim This_Week As Date      '←現在表示されている週の初日値
  20.  Dim Save_Range As Range     '←現在表示されている週のデータを保存する範囲
  21.  Dim New__Range As Range     '←次に表示する週のデータが保存されている範囲
  22.  Dim Save_Cell_Top As Long    '←保存データ範囲の行位置(現在表示されている週)
  23.  Dim New__Cell_Top As Long    '←保存データ範囲の行位置(次に表示する週)
  24.  This_Week = Sheets("sheet1").Cells(2, 2).Value    '←現在表示されている週の初日値
  25.  Next_Week = This_Week + ScrollBar1.Value * 7     '←次に表示する週の初日値
  26.  If Next_Week < Start_Day Then     '←スクロールバーで指示した週が設定初日週より前だったら
  27.   Next_Week = Start_Day        '←次に表示する週は設定初日週にする
  28.  ElseIf Next_Week > End_Day Then    '←スクロールバーで指示した週が設定最終日週より後だったら
  29.   Next_Week = End_Day         '←次に表示する週は設定最終日週にする
  30.  End If
  31.  Save_Cell_Top = (This_Week - Start_Day) / 7 * Memo_Range.Rows.Count      '←週の数 x 行数/週
  32.  Set Save_Range = Save_Top.Offset(Save_Cell_Top, 0).Resize(Memo_Range.Rows.Count)  '←保存週のセル範囲を計算
  33.  New__Cell_Top = (Next_Week - Start_Day) / 7 * Memo_Range.Rows.Count      '←週の数 x 行数/週
  34.  Set New__Range = Save_Top.Offset(New__Cell_Top, 0).Resize(Memo_Range.Rows.Count)  '←表示週のセル範囲を計算
  35.  Call Shape_Cut(Save_Range)           '←保存週の範囲にある図形を削除
  36.  Call Cell_Width(Memo_Range, Save_Range)    '←保存先の列幅を記入幅よりも広くする
  37.  Call Copy_Paste(Memo_Range, Save_Range)     '←記入範囲をCopyし、保存範囲にPasteする
  38.  Save_Range(1).Offset(0, 1) = This_Week     '←保存範囲の右肩部に日付を記入
  39.  Call Shape_Cut(Memo_Range)           '←記入範囲にある図形を削除する
  40.  Call Line_Draw(New__Range)           '←新しく表示した週が初表示の時に日毎の線を入れる
  41.  Call Copy_Paste(New__Range, Memo_Range)    '←保存範囲をCopyし、記入範囲にPasteする
  42.  Sheets("sheet1").Cells(2, 2).Value = Next_Week   '←1週間の日付の元データ部に日付を記入
  43. Value0:               '←枠線に図形が掛かっていた時に飛んでくる先
  44.  Bar_0 = True           '←コントロールバーを動かした時に登録マクロを作動させない
  45.   ScrollBar1.Value = 0      '←スクロールバーの値(Value値)をゼロにしてバーを中央に戻す
  46.  Bar_0 = False          '←バーを動かした時に登録マクロが動く様にする
  47.  Application.ScreenUpdating = True    '←画面更新をする(新しい週を表示させる)
  48.  If Next_Week = Start_Day Then      '←表示週が設定初日週だったらコメントを出す
  49.   MsgBox "スケジューラ初日週です"
  50.  ElseIf Next_Week = End_Day Then     '←表示週が設定最終日週だったらコメントを出す
  51.   MsgBox "スケジューラ最終週です"
  52.  End If
  53. End Sub
図3-3

3-1.変数・定数宣言部

①の2~6行目は、全体で使用する変数・定数を宣言・設定しています。
2行目は、フラグ変数です。スクロールバーで表示週を変更した後にスクロールバーを中立に戻す処理をしています(次の表示週変更操作に対応できるようにする為)が、中立にする(Value値をゼロにする)事により、「スクロールバーの値が変更された」と判断されて、スケジュール帳の再表示処理が自動的に入ってしまいます。
そこでマクロ側でValue値をゼロに変更する時には、フラグ「Bar_0」をTrueにし表示操作中止させています。

3~4行目のMemo_Range変数、Save_Top変数は、それぞれスケジュール帳の記入欄のセル範囲、保存シート(今回はSheet2)の保存領域の先頭セル位置 を変数として宣言しています。本来は定数として設定したいのですが、Rangeは定数として宣言できません。アドレスを文字列として定数にする方法もあるでしょうが、コードが複雑になりそうでしたので、今回はこのような設定としました。

5~6行目は、開始週・最終週の日付を定数として宣言しています。日付を定数宣言する場合は日付の両端に#をつけますが、例えば「#2019/12/29#」と入力しても勝手に5~6行目の様な書式に変更されます。
保存先であるSheet2は、最近のExcelであれば100万行以上ありますので、ざっと900年保存できますので最終週の定数はあまり意味がありません。一方、保存データは1行目から保存させていますので開始週は必要になります。昔のスケジュールを記入する場面は少ないと思いますが、シートの真ん中辺りから保存するようにすれば、開始・終了の制限は実質必要なくなるかもしれません。

3-2.スケジュール記入範囲、保存範囲の設定

②の8~11行目は、スケジュール記入範囲・保存範囲の設定プロシージャです。
スケジュール記入範囲は、今回は Sheet1のC3~C23セルに設定し、この範囲内に図形等を含めたスケジュールを記入します。また保存範囲はSheet2のA列に設定し、変数であるSave_Topにはその先頭セルを代入しています。
この変数はRange型なので、変数宣言は宣言部でしても、どこかのプロシージャ内でないと値は代入できません。通常はファイルを開いた時に実行されるWorkbook_Open イベントプロシージャに記述する事が多いと思いますが、Workbook_Open で記述するという事は、コードを「ThisWorkbook」側と「Sheet1」側に分けて書くことになります(スクロールバーの登録マクロは Sheet1 に書かざるを得ませんので)。つまり異なるモジュール間で変数をやり取りすることになるので、どうしても Public変数を使う事になります。
また、メインコードをThisWorkbookに記述したとしても、スクロールバーの登録マクロはSheet1になりますので、Public Sub で記述するプロシージャが出てきます。
「なんでPublicを使ったらいけないんだ?」と思われるかもしれませんが、「変数・プロシージャはできるだけ狭い範囲で使う」が原則です。今回の場合はBookに1つの機能しか入れていませんが、複数の機能を入れた場合には異なる機能側から余計な変数やプロシージャが見えてしまう事になるので、間違いの元になります。
ということで、今回は「スクロールバーを操作する」というイベントを発生出来るものがありますので、その操作の時(17行目)に代入する事にしました。
また、この文章を書いていて思い出した事があります。以前、何らかのエラーでマクロが中断してしまった時の対応として、画面上に「リセット」というボタンを作り「動かなくなったら、このボタンを押してね」といって変数値などを再読み込みさせる手段を取っていた事がありました。今考えれば自分の手抜きを人に押し付けていたと反省していますが「必要になったら読み込み」なら許してもらえるかも、と思っています。

3-3.スクロールバーを動かした時の処理

③の13~67行目は、スクロールバーを動かし、Value値が変更になった時に作動するプロシージャです。
まず14行目の「Application.ScreenUpdating = False」は、処理時間が多くかかる画面更新を一時停止させるものです。マクロの処理過程は見えなくなりますが、処理時間は短くなります。
マクロ処理が終われば自動的に画面更新されますが、明示的に60行目の「Application.ScreenUpdating = True」で画面更新させています。

16行目は、画面再表示防止をしています。スクロールバーを動かしたことにより表示週変更の処理を行った後、スクロールバーを中立位置にするために57行目でValue値をゼロにしていますが、その処理が「スクロールバーの値をゼロに変更した」と判断されて、再び13行目からのプロシージャを動かそうとします。57行目の1つ前で「変数 Bar_0」にTrue を設定していますので「Value値をマクロでゼロにした時は、16行目で表示週変更の処理から抜けだす」ことになります。
「変数 Bar_0」はBoolean型なので規定値はFalse(=ゼロ)です。ユーザが最初にスクロールバーを動かした時には「Bar_0 = False」ですので、処理はもちろん正常に動作します。

17行目は、スケジュール帳記入欄の範囲を示す変数 Memo_Range が空(Rangeオブジェクトなので、 "" では無くIs Nothing )の時に8~11行目のRange_Setプロシージャを実行し、記入範囲・保存範囲を記憶させます。ファイルを開き、最初にスクロールバーを動かした時に実行されます。

18行目は、スケジュール記入欄範囲(C3:C23)の枠に跨った格好で図形が存在した場合に、注意を促すメッセージボックスを表示しマクロを終了します。「Shape_Group_XOR()」は自作の関数で、引数としてセル範囲(今回は、スケジュール記入欄範囲)を渡すと、その外枠上に図形が存在するか否かを確認し、存在するならばゼロを返すようにしてあります。
抜け出す先は「Value0」という55行目であり、「Exit Sub」ではありません。スクロールバーは既に動かされてしまっている為、Value値をゼロに戻しておかないと次の操作の時に支障が出るために、飛び先 Value0 以降で Value値をゼロに戻しています。

20~25行目は、このプロシージャの中で使用する変数の宣言です。
「Next_Week」は次に表示する週の初日値、「This_Week」は現在表示されている週の初日値を表します。また「Save_Range」は現在表示されている週のデータを保存する範囲、「New__Range」は次に表示する週のデータが保存されている範囲です。その関係を図3-4で示します。
また、Save_Cell_Top、New_Cell_Topは、保存シートの先頭からの距離です。(尚、この2つの変数は必須ではなく、37、39行目の式を見易くするために設定しました)


図3-4

27~28行目では、現在表示週と次に表示する週の日付を取得しています。
27行目は現在表示されている週の初日(日曜日)を代入しているのですが、その値(日付)は「Sheet1のB2セル」から読み取ります。これはデータをSheet2からコピーしてSheet1の記入範囲に貼り付けた(52行目)後、53行目で表示した週の日付を貼り付けているから、B2セルには表示週の初日値が書かれている訳です。
また28行目の「次に表示する週の日付」は、1行上で取得した表示週日付に対し、スクロールバーで動かした週の数だけズラす計算をしています。週は7日なので、スクロールバーの値に「7」を掛けています。

30~34行目は「次に表示する週の修正」です。スクロールバーは「開始週」や「最終週」に関係無く動かせますので、もし設定した値が開始週や最終週をオーバーしていた時に開始週・最終週に戻す処理です。

36~39行目は、図3-4の保存シート(Sheet2)側の「保存先(=現在の表示週 Save_Range)」と「次の表示週 New_Range」の位置・範囲を計算しています。
保存先であるSheet2は、先頭行からデータを保存しています。つまり先頭にはStart_Day 週のデータを置いてありますので、その差分と1週間の行数から該当するセル位置を計算させています。またその範囲は、先頭行(=Save_Top)からOffsetで行位置をズラした後、セル範囲を記入範囲分に広げています。

41行目からが、データをコピペしている部分です。

41行目では、図2-2でも説明しましたが、コピペをする前に図形を削除する工程を入れています。削除したい範囲「Save_Range」を引数で渡しています。
コピペをする前に貼り付け先の図形を削除する必要性ですが、コピー元に図形が存在する状態でコピーすると、図形もコピーされて貼り付け先に図形も貼り付きます。セルの値は書式も含めて貼り付け先に上書きされるのですが、貼り付け先に図形が存在していると貼り付けるときに元の図形が消えないので、コピー元の図形 + 貼り付け先の図形が重なった形になります。
セルの値も図形も全てを更新しないと意味がありませんので、自動的には消せない図形をまず削除しているのです。

43行目は「保存先の列幅を記入幅よりも広く」する操作をしています。
スケジュール記入画面(Sheet1)のセル幅は、ユーザが自由に変更できます。セル幅をユーザが広げてしまった時には、記入画面のセル幅(今回はSheet1のC列)の方が保存シートのセル幅(今回はSheet2のA列)よりも広くなります。すると保存をした場合にSheet2のA列からはみ出して保存されるオブジェクトが出てきます。(調べ切れていないのですが、列の右端に置いた図形が保存側の列の右端に貼り付く形で配置されるのが原因の様です)
また幅をユーザが狭くしてしまった時には、保存されていた図形が記入画面の端にへばりついてしまい、記入した時のレイアウトが崩れてしまいます。(こちらの対策は積極的に行っていませんが、図形が枠線を跨っていると人手で動かすことが出来ます。)
この不具合を避けるために、保存先の列幅は常に記入幅よりも同等以上にする機能をつけました。改造して、列幅をロックするような仕様にすれば不必要になると思います。

45~46行目で、現在表示されている画面を保存シート側に保存します。同時に保存シートの右肩部に保存したデータの日付を記入しています。
コピー元の範囲(今回は Memo_Range)を第一引数で、貼り付ける範囲(今回は Save_Range)を第二引数で渡しています。
保存シート側に日付を入れる意味ですが、新規の画面を表示した際に日付の境目である罫線を入れる(50行目のLine_Draw)ためです。

48行目では引数に「Memo_Range」を渡して、Sheet1のスケジュール記入欄範囲にある図形を削除しています。これは、41行目と同じ様な理由です。

50行目ですが、引数の「New__Range」の右肩部に日付がなかった時に、日付分割用に3行ごとに罫線を引いています。
これは46行目で「保存シートの右肩部に保存したデータの日付を記入」していますので、「日付が入っている = 使用されたことがある = ユーザが罫線を加工しているかもしれない」事から、「日付の無いデータのみ罫線を引いて」います。

52~53行目は、コピー元の範囲(今回は New_Range)を第一引数で、貼り付ける範囲(今回は Memo_Range)を第二引数で渡し、保存側(Sheet2)から記入側(Sheet1)へコピペをしています。その際、記入範囲左側の日付(計算式)の元データとなる週の初日日付をB2セルに書き込んでいます。

55行目の「Value0:」は、GOTO で飛ばす先の「行ラベル」です。18行目で記入枠に図形が跨っている時には、55行目に飛んでくるようにしています。
もし図形が跨ってコピペの処理をしなかったとしても、スクロールバーの位置を元に戻さなければならないために Value値をゼロにする処理だけはしておきます。
57行目は、そのスクロールバーのValue値をゼロに戻す命令です。しかしゼロに戻すと「スクロールバーの値を変更した」と判断して登録しているマクロ「ScrollBar1_Change」を実行しようとします。記入側シート(Sheet1)と保存側シート(Sheet2)の間で同じ週のデータをコピペするだけなので表面上は変化ありませんが、無駄な工程です。
その工程を中断させるために、Value値をゼロにする直前(56行目)でフラグの役目をしている変数Bar_0をTrueにしています。このフラグにより、一旦「ScrollBar1_Change」を実行しても16行目で抜け出してくれます。抜け出して戻ってきたら58行目でBar_0を規定値のFalseに戻します。

60行目では、14行目からの画面更新ストップを解除し、画面更新(=新しい週のデータに切り替わっている)されます。

62~66行目は、新しく表示した週が「スケジュール表開始週」または「最終週」であった時に、そのコメントをMsgBoxで出します。
MsgBoxなので「OKボタン」を押さないと、スケジュール記入・スクロールバー操作は出来ません。Msgboxの代わりに図3-5の様な「Windows Scripting Host」のPopupメソッドを使用すると、自動的(図3-5の例では1秒後)にメッセージが消えますので、状況によって使い分けて下さい。
  1. '======= 63行目の代わりに使うとした場合  ================
  2. Dim WSH As Object
  3. Set WSH = CreateObject("WScript.Shell")       '←Windows Scripting Hostをオブジェクトとして取得
  4. WSH.Popup "スケジューラ初日週です", 1, "", vbExclamation     '←Popupメソッドを実行
  5. Set WSH = Nothing
図3-5

また別な方法として、図3-6の様にUserFormにコメントを書いておき、表示している時間を制御する方法もあります。尚、この場合はShowメソッドの引数としてvbModeless(値としてはゼロ)を指定して下さい。規定値のvbModal (または、引数を設定しない)では次のコードへ進んでくれず、UserFormが表示されっぱなしになります。
  1. '======= 63行目の代わりに使うとした場合 (UserForm1 には、コメントが書いてあるとして) ======
  2. UserForm1.Show 0      '←必ずvbModeless 又は 0 を指定
  3. Application.Wait (Now + TimeValue("0:00:01"))
  4. UserForm1.Hide
図3-6

4.サブプログラムの説明

3項のメインプログラムから呼び出されて実際に仕事をするのが、これから説明するサブプログラムです。

4-1.指定範囲に含まれる図形を取得し、削除するマクロ

図形を削除する前に、削除する図形を捜す必要があります。そのための「指定範囲に含まれる図形を取得」する関数が図4-1です。
  1. '============ ⇩④ 指定範囲に含まれる図形を取得する関数  =============
  2. Function Shape_Range(R) As Variant()   '←範囲Rに完全に入っている図形を返す関数
  3.  Dim S_Array() As Variant        '←図形(=図形を示す文字列)を入れる配列を宣言
  4.  Dim i As Long              '←カウンター用変数(=図形の数を表している)
  5.  i = 0                  '←図形数の初期値はゼロ
  6.  For Each c In R .Parent.Shapes     '←範囲Rのあるシート内の図形を全て調べる
  7.   If Not Intersect(c.TopLeftCell, R) Is Nothing _
  8.    And Not Intersect(c.BottomRightCell, R) Is Nothing Then  '←範囲R内に図形の左上・右下が入っている
  9.     i = i + 1             '←図形数の値を1つ増やして
  10.     ReDim Preserve S_Array(1 To i)  '←図形を入れる配列を1つ増やして
  11.     S_Array(i) = c.Name        '←図形の名前を配列に格納する
  12.   End If
  13.  Next c
  14.  Shape_Range = S_Array          '←範囲R内に入っている図形の名前を入れた配列を返り値として返す
  15. End Function
図4-1

この関数「Shape_Range」は引数として「シート名も含めたセル範囲」を受け取ります。引数R は、図4-9の87行目から渡され、またその87行目は図3-3の41行目・48行目から渡されてきます。
関数の返り値としては「図形を表す文字列の配列」になるので、タイプはString型とも考えましたが、この返り値を受け取る図4-9の87行目の「(Worksheet).Shapes.Range(返り値)」を調べてみるとVariant型で受けていましたので、図4-1のShape_Range関数もVariant型としました。(もう少し調べる必要はあるかもしれません)

70行目の変数 S_Array は、このプロシージャ内で使用する配列です。この配列の中に図形を表す文字列を代入し、最後にまとめてこの関数の返り値に渡します。

74行目で対象シート内の図形を全て取り出して順次調べていきます。調べる要素であるShapesコレクションは、WorksheetオブジェクトのShapesプロパティで求めますが、引数として渡されているのはセル範囲だけですので、Worksheetオブジェクトは「R . Parent」(セル範囲の親 = ワークシート)で求めています。
そして調べる図形が指定範囲に入っているか否かは、75~76行目で調べていますが、今回はIntersectメソッドを使用しています。Intersectは、第1引数と第2引数に渡した各セル範囲の重なっているセル範囲を返してくるものです。
75~76行目のIF文を図4-2の例を使って見てみましょう。プロシージャとして渡された引数Rを黄色範囲(D3:F9)とし、シート上にはイロハニホの5つの図形が存在するとします。それぞれの図形に赤丸(左上)・黒丸(右下)をつけてありますが、その印が乗っているセルが「c.TopLeftCell」(赤丸)、「c.BottomRightCell」(黒丸)になります。

図4-2

まず75行目(IF文の前半部分)は、図形の左上セル(赤丸)と渡された指定範囲(黄色範囲)との関係を、そして76行目(IF文の後半部分)は、図形の右下セル(黒丸)と渡された指定範囲(黄色範囲)との関係を調べています。重なっている場合はそのセル範囲を返してきますし、重なっていない場合はNothngを返します。For Each Next を使ってそれぞれの図形について調べた結果は図4-3の様になります。
図形 Intersect (c. TopLeftCell,  R)  Intersect (c. BottomRightCell,  R) 
NothingRange("D5")
Range("F9")Nothing
Range("E5")Range("F7")
NothingNothing
NothingNothing
図4-3

IF文の中で、Intersectの返り値を「Is Nothing」で調べています。これはIntersectの返り値がRangeオブジェクトであるためで、セルが空か否かを調べるような「IF 〇〇 = "" Then ・・」みたいな比較演算はできません。
Intersectの返り値がNothing の時だけ、イコールが成立しTrue が返されます。(図4-4)
図形 Intersect (c.TopLeftCell, R)  Is Nothing  Intersect (c. BottomRightCell, R)  Is Nothing 
TrueFalse
FalseTrue
FalseFalse
TrueTrue
TrueTrue
図4-4

そのTrue、False に対して先頭に「Not」をつけると、True と False が反転します。(図4-5)
図形 Not Intersect (c. TopLeftCell, R)  Is Nothing  Not Intersect (c. BottomRightCell, R)  Is Nothing 
FalseTrue
TrueFalse
TrueTrue
FalseFalse
FalseFalse
図4-5

75行目と76行目は「AND」でつながっていますので、両方ともTrueの時のみTrueになります。(図4-6)
図形 Not Intersect (c.TopLeftCell, R)  Is Nothing AND Not Intersect (c.BottomRightCell, R)  Is Nothing 
False
False
True
False
False
図4-6

ということで、黄色範囲に完全に含まれているのは「図形ハ」のみ、という判断ができるのです。
このようなロジックで指定範囲に含まれている図形が存在する場合は、図4-1の77行目に進みます。
77行目でカウンター変数に1を足し、78行目で配列のサイズを1つ大きくします。この時に1つ前までの配列の値を保持するようにPreserveオプションを付けます。
79行目で、サイズを広げた配列の最後に「指定範囲に含まれている図形の名前」を代入します。
全ての図形に対して同様の処理をした後、82行目でその配列をShape_Rangeの返り値にする処理をします。

ちなみに、図4-6の「AND」を「OR」に変えると「どちらかがTrueならばTrue」になり「範囲に少しでもかかっている図形も取得」できそうですが、そうはいきません。
図4-6の図形「ホ」をみて下さい。実際には黄色のセルに跨っているのに、結果はFalse(=重なっていない)と計算されてしまいます。図形の左下は重なっているのですが、計算式では左上と右下しか判断の材料に入れていない為です。

ではどうするか。「図形の左上・右下のセル」ではなく、図4-7のように「図形を全て含む範囲」と黄色範囲を比べれば良いのです。

図4-7

図形を全て含むのですから、通常の範囲指定と同じようにRangeの引数に左上セルと右下セルを指示して「 Range(c.TopLeftCell, c.BottomRightCell) 」とすれば図形を含むセル範囲が取得できます。
あとは、図4-3以降と同様に、「 Is Nothing 」と「 Not 」で判断式を作っていきます。
図形 Intersect(Range(c.TopLeftCell, c.BottomRightCell), R) 
Range("D3:D6")
Range("F9")
Range("E5:F7")
Nothing
Range("F3")
          
図形 Intersect(Range(c.TopLeftCell, c.BottomRightCell), R)  Is Nothing 
False
False
False
True
False
          
図形 Not Intersect(Range(c.TopLeftCell, c.BottomRightCell), R)  Is Nothing 
True
True
True
False
True
図4-8

ということで、一部でも重なる図形の判断式 = Not Intersect(Range(c.TopLeftCell, c.BottomRightCell), R) Is Nothing
となります。


次に、図4-1の関数を使用して、実際に図形を削除するのが以下のプロシージャです。尚このプロシージャは、図3-3の41行目と48行目から呼び出されるものです
  1. '============ ⇩⑤ 指定範囲の図形を削除するプロシージャ  ========================
  2. Sub Shape_Cut(R As Range)
  3.  On Error Resume Next                '←範囲R内に図形が無い場合はスルーする
  4.   R.Parent.Shapes.Range(Shape_Range(R)).Delete  '←範囲R内にある図形を削除
  5.  On Error GoTo 0
  6. End Sub
図4-9

87行目の.Range()のカッコ内で図4-1の関数を使用していますので、引数Rの範囲に含まれている図形の名前の配列が.Range()のカッコ内に返ってきます。.Range()のカッコ内に決まった図形の名前を入れる場合は「.Shapes.Range(Array("A","B","C")」の様に書きますが、Arrayといえば配列ですね。つまり、.Range()のカッコ内にいれるのは配列なので、図4-1の Shape_Range関数の返り値は配列にしたのです。
87行目の一番右側には .Delete メソッドがついていますので、選択された図形を削除することができます。

しかし、Shape_Range(R)関数で範囲R内に1つも図形が存在しない場合もあります。その時Shape_Range(R)は配列要素の無い状態ですので、87行目は図形を確定できずエラーが発生します。
ですので、その直前の86行目の「On Error Resume Next」で、87行目でもしエラーが出ても次に進む ようにさせています。削除する図形がないだけですので特にエラーコードを出す必要も無く、エラーを無視したら88行目で元に戻します。

4-2.指定範囲の外枠に跨っている図形を取得し、注意喚起するマクロ

4-1(指定範囲に含まれる図形を取得)と同様の流れで、まず「指定範囲の外枠に跨っている図形を取得」する関数です。
  1. '============ ⇩⑥ 指定範囲の枠を跨っている図形を取得する関数  ========================
  2. Function Shape_Range_XOR(R) As Variant()         '←範囲Rの境界線を跨いでいる図形を返す関数
  3.  Dim S_Array() As Variant                '←図形(=図形を示す文字列)を入れる配列を宣言
  4.  Dim i As Long                      '←カウンター用変数(=図形の数を表している)
  5.  i = 0                          '←図形数の初期値はゼロ
  6.  For Each c In R.Parent.Shapes               '←範囲Rのあるシート内の図形を全て調べる
  7.   If (Not Intersect(Range(c.TopLeftCell, c.BottomRightCell), R) Is Nothing) Xor _
  8.    (Not Intersect(c.TopLeftCell, R) Is Nothing _
  9.    And Not Intersect(c.BottomRightCell, R) Is Nothing) Then  '←範囲Rに図形が跨っている場合は
  10.     i = i + 1                       '←図形数の値を1つ増やして
  11.     ReDim Preserve S_Array(1 To i)            '←図形を入れる配列を1つ増やして
  12.     S_Array(i) = c.Name                 '←図形の名前を配列に格納する
  13.   End If
  14.  Next c
  15.  Shape_Range_XOR = S_Array    '←範囲Rの境界線に跨っている図形の名前を入れた配列を返り値として返す
  16. End Function
図4-10

図4-10は、図4-1のShape_Range(R)関数とほぼ一緒です。異なっているのは97~99行目のIF文で、その内98~99行目は図4-1と全く同じですので、IF文の後半は「範囲R内に完全に含まれている図形」を意味します。

図4-7のところで説明した通り、
1)完全に重なる図形  = Not Intersect(c.TopLeftCell, R) Is Nothing AND Not Intersect(c.BottomRightCell, R) Is Nothing
2)一部でも重なる図形 = Not Intersect(Range(c.TopLeftCell, c.BottomRightCell), R) Is Nothing
となります。

1)と2)の関係は、 「2)一部でも重なる図形」=「1)完全に重なる図形」+「3)一部でしか重ならない図形」 です。
なので、「指定範囲の外枠に跨っている図形」を得るには、「2)一部でも重なる図形」から「1)完全に重なる図形」を取り除けば良いわけです。
と言って、単純に引き算をする訳にもいきません。1つの方法としては、IF文で「2)一部でも重なる図形」を拾い上げ、次に「1)完全に重なる図形」では無い図形を拾い上げる というやり方もあります。
もう一つの方法は、「排他的論理和(XOR)」という方法です。これは、両方が同じ(両方True または 両方False)であればFalse、異なれ(一方がTrue、一方がFalse)ばTrueと計算します。図で書くとすると図4-11の右側のように、境界に跨る図形のみを抽出することが出来ます。

図4-11

式としては、上の黄色く塗った「1)完全に重なる図形式」と「2)一部でも重なる図形式」を「XOR」で結びます。
図形 1)完全に重なる図形式  2)一部でも重なる図形式 
FalseTrue
FalseTrue
TrueTrue
FalseFalse
FalseTrue
          
図形 1)完全に重なる図形式 XOR 2)一部でも重なる図形式 
True
True
False
False
True
図4-12

ということで、図4-10の97~99行目のIF文が完成します。
他の流れは、図4-1と全く同じです。

次に、図4-10の「指定範囲の外枠に跨っている図形」のデータを使って、図4-13の通り処置をします。
この関数は、図3-3の18行目から呼び出されます。
  1. '============ ⇩⑥ 指定範囲の枠に図形が跨っている時の処置プロシージャ  =======================
  2. Function Shape_Group_XOR(R)
  3.  On Error Resume Next                    '←枠に跨る図形が無い場合にはエラーが発生する
  4.   R.Parent.Shapes.Range(Shape_Range_XOR(R)) .Select    '←範囲Rの枠に跨っている図形を選択
  5.   If Err = 0 Then                      '←範囲Rの枠に図形が跨っている場合
  6.    MsgBox "記入枠と重なっている図形があります" & vbCrLf & "枠に掛からない様に調整して下さい"   '←忠告
  7.   End If
  8.   Shape_Group_XOR = Err   '←跨っている場合は週の移動をストップさせるフラグを立てる
  9.  On Error GoTo 0
  10. End Function
図4-13

110行目で、図4-10の関数を使用して範囲Rの外枠に跨っている図形を取得し、その図形を選択(Select)しています。選択するのは、どれが跨っている図形なのかをユーザに知らせるためです。
しかし、外枠に跨っている図形が無い場合もありますので、このままですと「選択する図形が無いのに選択しようとするとエラー」が発生します。それを回避するために直前の109行目で「On Error Resume Next」を入れ、エラーが発生しても次に進む様にしています。
エラーが無い時はErr番号はゼロ、エラーが発生するとゼロ以外のErr番号が発生しますので、そのErr番号を元に警告などの処置をするのが普通ですが、ここでは「範囲Rの外枠に跨った図形があり、選択できた」ことでErrが発生しなかったことを利用(111行目)して、112行目で警告を出しています。
そして、Err番号をこの関数の返り値にして(114行目)、プロシージャを抜けます。
なお、115行目の「On Error GoTo 0」の位置ですが、本関数プロシージャの一番最後に置いています。これは「On Error GoTo 0」を通過するとErr番号が消えてゼロに戻ってしまうため、114行目で関数の戻り値を設定したあとでErr番号をリセットさせています。

なお、この関数を受け取るコード(図3-3の18行目)を再掲します。
「 If Shape_Group_XOR(Memo_Range) = 0 Then GoTo Value0 」
「関数の返り値= 0 」としていますので、この関数がゼロ(範囲Rの外枠に跨る図形があった)だったら、画面のコピペなどの処置工程は飛ばし、行ラベル Value0 以降の「スクロールバーを中立に戻す」作業をするのです。

4-3.指定範囲をコピペするマクロ

図3-3の45、52行目で実施されるコピペの部分のプロシージャです。
  1. '============ ⇩⑦ 指定範囲から指定範囲へコピペするプロシージャ  =======================
  2. Sub Copy_Paste(R1, R2)
  3.  Dim CopyObjectsNG As Boolean
  4.  If Application.CopyObjectsWithCells = False Then
  5.   CopyObjectsNG = True
  6.   Application.CopyObjectsWithCells = True    '←セルをコピーした時に図形も一緒にコピーされるモードにする
  7.  End If
  8.  R1.Copy R2           '←R1の範囲をコピーし、R2に貼りつける
  9.  If CopyObjectsNG = True Then
  10.   Application.CopyObjectsWithCells = False
  11.  End If
  12. End Sub
図4-14

125行目の「R1.Copy R2」がこのプロシージャの本体です。プロシージャの第一引数R1の範囲をコピーし、第二引数R2の範囲へペーストしています。
Copyメソッドに引数を与えずにCopyメソッドを実行し、その後Pasteメソッドを使用する(人手で行うコピペと同じ)と、コピーした段階でデータがクリップボードに一旦保存され、ペーストで貼り付く事になります。ですのでPaste後もデータが残っている間は再びPasteできます。
しかし、125行目のように Copyメソッドに引数を与えて使用すると、データはクリップボードを経由しないために、その後 Paste をしても貼り付けられるものがなく、エラーが発生しますので注意が必要です。

また、今回のスケジュール帳アプリでは、セル内容・セル書式と一緒に「図形も一緒にコピペ」されないと存在意義が薄くなります。標準でExcelを使っていれば図も一緒にコピペされるのですが、Excelの設定で切り替えられるようになっています。
Excelのファイルタブ→オプション→詳細設定 を選び、「切り取り、コピー、貼り付け」の項目の「挿入したオブジェクトをセルとともに切り取り、コピー、並べ替えを行う」にレ点が付いているか確認してみて下さい。(図4-15)

図4-15

このオプションをOFF(=レ点を外している)にしていると、図が一緒に行かなくなってしまうので、図4-14の119~123行目でマクロ側でONにする処置をしています。
まず、開いているExcelの「(略)セルと共にコピーオプション」の設定がどうなっているかを120行目で確認しています。確認方法は「Application.CopyObjectsWithCells」プロパティを調べ、TrueであればON、FalseであればOFF と分かります。
OFFであれば、122行目の様に「Application.CopyObjectsWithCells = True」を設定することでONになりますが、ユーザが「自覚してOFFにしている」場合もあります。勝手に個人の設定を変更してしまうのもマズイですし、他のアプリで不具合が出てくる可能性もあります。
ですので、このスケジュール帳を「使用する間だけONにして、終わる時には元の状態に戻す」ことを考えました。それが119行目で宣言しているCopyObjectsNG変数です。ExcelがOFF設定の時は121行目で変数にTrueのフラグを立て、コピー動作が終了したら128行目で元に戻す作業をしています。

4-4.指定範囲の列幅を広げるマクロ

図3-3の43行目から呼び出されているプロシージャです。第一引数R1・第二引数R2は両方ともセル範囲(Range型)で、R2のセル幅をR1のセル幅と同等以上(もともと幅が広い場合もある為)にするものです。
セル幅にこだわる理由は、Sheet1のスケジュール記入側で図形を右枠線近くに配置した際、記入側のセル幅の方が保存側(Sheet2)より広い場合には、保存側では図形がセル幅の右端に貼り付く形になります。右端に貼り付いていても図形は拾えるはずなのですが、試行してみると時々拾いのがして、図形がどんどん重なっていく現象が見られました。
微妙な図形位置がエラーを引き起こしているようなので、保存側のセル幅を記入側以上にする事で、エラー発生を抑えることにしました。ちょっと現場的な手法ですがお許し下さい。
  1. '============ ⇩⑧ 指定範囲の列幅を広げるプロシージャ  =======================
  2. Sub Cell_Width(R1, R2)                '←保存先の列幅を記入幅よりも広くするプロシージャ
  3.  If R1.ColumnWidth > R2.ColumnWidth Then    '←記入部より保存部の幅が狭かったら
  4.   R2.ColumnWidth = R1.ColumnWidth      '←記入部と同等のセル幅に設定する
  5.  End If
  6. End Sub
図4-16

流れはいたって簡単で、133行目でセル幅のサイズを比較し、R2の方が狭かった場合は134行目でR1同等にしています。
尚、このプロシージャは一般的には使えません。まずは引数のR1とR2の列数が単列(1列)の時しか考慮されていません。R1に複数列の範囲を指定した場合には、最左列の列幅しか評価せず、変更する側のR2の幅は複数列を指定したとしても全てR1範囲の最左列と同じ列幅になります。
もし、記入側の画面で複数列で使用したい方は、1列ずつCell_Widthプロシージャを流してください。但し、記入済みの図形の配置がズレる可能性もありますのでご注意をお願いします。

4-5.指定範囲に罫線を引くマクロ

スケジュール帳の記入欄は、3行/日 x 7日 にしていますが、日にち毎に罫線を引いておかないと使い辛そうと思われます(個人的な意見ですが)。ですので、保存シート側から「新品画面」を持ってくる際に日毎に罫線を入れるプロシージャを作成しました。
  1. '============ ⇩⑨ 日毎の罫線を引くプロシージャ  =======================
  2. Sub Line_Draw(R)                '←新しく表示した週が初表示の時に日毎の線を入れるプロシージャ
  3.  If R(1).Offset(0, 1) <> "" Then Exit Sub  '←右肩に日付が記入(ユーザが罫線を変更している可能性有り)されていたら
  4.  For i = 1 To 6
  5.   With R(i * 3 + 1).Borders(xlEdgeTop)  '←3行ずつ罫線を記入
  6.    .LineStyle = xlContinuous       '←実線
  7.    .Weight = xlHairline         '←極細線
  8.   End With
  9.  Next i
  10. End Sub
図4-17

まず、保存側(Sheet2)のデータの右肩部に週の日付が記入されます(図3-3の46行目)。この記入のタイミングは、記入側にある記入済みデータを保存側にコピぺした直後です。つまり「保存側データに日付が入っている = 記入済み」を意味しています。
記入済みと言うことは罫線も自分で加工した可能性がありますので、プログラム側で勝手に罫線を修正するのはよくありません。よって日付の入ったデータの場合には罫線を引かないままプロシージャを抜ける(139行目)ようにしています。

日付の入っていない(=初めて記入側に表示した)データの場合は、罫線を引いていきます。
141~146行目の通り、3行/日ですので3行飛びにセルの罫線を変更します。7日/週なのに6回しかForを回していないのは、記入シート側にの太枠線があるので、日と日の間(7-1=6)を引いています。
罫線には色々な種類がありますので、必要でしたら変更してください。


5.残された課題

今回のスケジュール帳には、いくつか課題が残されていると思っています。

5-1.2週に渡って表示できない

今回スケジュール帳を作るに当たり、2週分を「1・2週」、「2・3週」、「3・4週」みたいに並べて表示して、週を跨いだ矢印など(例えば、日程を延期した等)を記入したいと思いました。しかし保存するデータの単位は1週間にする必要があるので、週に跨った図形は週の境目で分割しなくてはいけません。
調べた結果、図形の分割機能はPower_Point にはあるのですが、Excelでは無理のようでした。これが可能になれば、1UPできるのに残念です。

5-2.データが溜まっていくとファイルサイズが大きくなる

20年前にも発生した問題ですが、データが溜まっていくとファイルサイズが大きくなってしまうことです。特に図形を一緒に保存しているため尚更厳しくなります。
Worksheet当たりに保存できる週の数を限定し、新しいデータは新しいシートに保存し、古くなったデータはシート毎削除する(又は移動する)ような機能や、古いデータを消して行削除しStart_Day を持ち上げるような機能などを盛り込む必要がありそうです。

5-3.図形のグループ化

長期間使用し保存シートの図形データが増えてきた時、指定範囲内の図形を捜す機能を Shape_Range(R) 関数で実現させていますが、そのプロシージャの中では「For Each c In R .Parent.Shapes」と、データシート全体の図形を1つずつ調べている事になります。つまり図形の数が多いほど時間が掛かることになります。
そこで、保存シート内では「週毎に図形をグループ化」しようと考えました。以下がそのプロシージャです。
  1. '============ ⇩ 図形をグループ化するプロシージャ  =======================
  2. Sub Shape_Group(R)
  3.  On Error Resume Next                '←範囲R内に図形が無い、又は1個の場合はスルーする
  4.   R.Parent.Shapes.Range(Shape_Range(R)).Group  '←範囲R内にある図形をグループ化
  5.  On Error GoTo 0
  6. End Sub
  7. '============ ⇩ 図形のグループ化を解除するプロシージャ  =======================
  8. Sub Shape_UnGroup(R As Range)
  9.  On Error Resume Next                '←範囲R内に図形が無い、又は1個の場合はスルーする
  10.   R.Parent.Shapes.Range(Shape_Range(R)).Ungroup  '←範囲R内にある図形をグループ化
  11.  On Error GoTo 0
  12. End Sub
  13. '============ ⇩ メインプログラムの中で呼び出すコード  =======================
  14.   Call Shape_Group(Memo_Range)      '←記入側から保存側にコピペする直前に実行
  15.   Call Shape_UnGroup(Memo_Range)     '←保存側から記入側にコピペした直後に実行
図5-1

しかし試行してみた結果、図形をGroup化すると元の図形の範囲より一回り大きくなってしまい、保存側の範囲よりもオーバーしてしまう可能性に気が付きました。すると、コピー・ペースト前に削除できない図形が出てきて、表示画面で図形が重なる不具合も確認できました。(枠の内側に完全に入っている図形しか削除していないため)
これの解決策として、保存範囲の外枠に跨っている図形も削除する方法も考えられますが、前週・翌週のデータまで切ってしまう可能性も発生しますし、あらかじめ保存側の四方に余裕を持たせるか、記入側の四方に余裕を持たせる方法くらいしか、今のところ思いつきません。

5-4.コピペした時の図形位置とセル範囲の関係

今回は、セル範囲内に図形が完全に入っている状態で「表示画面」と「保存シート」との間で「セル範囲のコピー・ペースト」で行っています。で、なんとなくセル範囲から少しはみ出した図形でコピーしてみると、図形コピーが成功しました。
ではどの位置までコピー可能か試してみると、「図形の中心がセル範囲に入っているとコピーできる」ような感じでした。
色々なサイトを調べているのですが、どこにも載っていないので、ちょっと面白そうな課題です。

5-5.最初の表示週に日毎の罫線が引いていない

罫線を引くプロシージャは、保存側から表示側にデータを持ってくる時に動作します。つまり、新品状態の時には罫線が引いていないのです(引くタイミングが無い、と言った方が正確かもしれません)。申し訳ないのですが、必要な方は罫線を引いてから使って下さい。


6.最後に

時代遅れのスケジュール帳とは言え、とりあえず試行くらいは出来るように作ってみました。初めに書いたように、セルデータと同時に図形などのオブジェクトを扱うのは、結構手間です。今回検証しませんでしたが「図形の位置がズレてしまう」不具合も様々なサイトで扱っているようです。
Excelは表計算ソフトで、この様なメモ帳的な使い方は可能とは言え邪道とも言えますが、並べたデータだけを見ていても何も分からないことも事実です。データを可視化する為にも、グラフ・図形の様なオブジェクトが必要になるのも確かです。
表計算ソフトとしてのExcelを意識しながら、データを活かす事に注力すべきと思います。


図形も貼り付けられるスケジュール帳(it-017.xlsm 約42KB)

セキュリティ向上を目的として「インターネット経由でダウンロードしたOfficeファイル(Excel等)のマクロは、既定でブロック」されるようにOfficeアプリケーションの既定動作が変更になりました。(2022年4月より切替開始)
解除の方法については「ダウンロードファイルのブロック解除方法」を参照下さい。