エクセルでここまでできる！予定が書き込める万年カレンダー シートの存在を確認し、なければ新規にシートを作成 土日でマスター エクセルVBA講座⑥

今回も、エクセルでの万年カレンダーの作成です。

前回はコントロールのボタンを利用して、クリック一つで翌月や前月、翌年に移動する方法を記事にしました。

今回はカレンダーの月や年を移動してもセルに書き込んだ予定が消えない、まさに一生利用できる万年カレンダーをマクロで作成します。

今回作成カレンダーの仕様の紹介

今回の記事は、先に紹介した2つのカレンダーの記事をご覧になって、万年カレンダーが完成していることと、フォームボタンによる月や年の移動が可能なカレンダーが完成していることが前提となります。

下図のようにセルに予定を書き込みが可能です。

そして翌月にフォームコントロールボタンによって翌月に移動します。

ここでも予定の書き込みが可能です。

そして今回の最大の機能である、再び前月に戻ると先ほど記入した予定が、下図のよう表示されます。

この機能は、月または年を移動する際に別シートを作成し、マクロによって予定を保存・更新しているために予定が消えることはありません。

実際には、マクロによってこちらのシートは非表示になります。

それでは、実際のマクロを見てみましょう。

予定を転記・更新するシートを作成・更新するマクロ

まずはカレンダーで翌月に移動する際に、予定を書き込み、移動する月の予定を読み込むマクロの全体像は以下となります。

かなり複雑な処理をしていますので、後から解説していきます。

Sub ボタン3_Click()
myMonth = Range("c1").Value
mySheetName = Replace(Range("c1").Value, "/", "")
'現在の月のシートがあるか確認
For i = 1 To Worksheets.Count
If Worksheets(i).Name = mySheetName Then
myFlag = True
Exit For
Else
myFlag = False
End If
Next i
'現在の月のシートがなければ新規作成
If myFlag = False Then
Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = mySheetName
End If
'現在の月のデータをコピー
Worksheets(mySheetName).Range("a5:g5").Value = Worksheets("カレンダー").Range("a5:g5").Value
Worksheets(mySheetName).Range("a8:g8").Value = Worksheets("カレンダー").Range("a8:g8").Value
Worksheets(mySheetName).Range("a11:g11").Value = Worksheets("カレンダー").Range("a11:g11").Value
Worksheets(mySheetName).Range("a14:g14").Value = Worksheets("カレンダー").Range("a14:g14").Value
Worksheets(mySheetName).Range("a17:g17").Value = Worksheets("カレンダー").Range("a17:g17").Value
Worksheets(mySheetName).Range("a20:g20").Value = Worksheets("カレンダー").Range("a20:g20").Value
'現在の月のワークシートを非表示
Worksheets(mySheetName).Visible = False
'翌月のシートがあるか確認
'12月の場合に注意
If Right(mySheetName, 4) = "1201" Then
myNextSheetName = Trim(mySheetName + 8900)
Else
myNextSheetName = Trim(mySheetName + 100)
End If
For i = 1 To Worksheets.Count
If Worksheets(i).Name = myNextSheetName Then
myFlag = True
Exit For
Else
myFlag = False
End If
Next i
'翌月のシートがなければ新規作成
If myFlag = False Then
Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = myNextSheetName
End If
'翌月のデータをカレンダーにコピー
Worksheets("カレンダー").Range("a5:g5").Value = Worksheets(myNextSheetName).Range("a5:g5").Value
Worksheets("カレンダー").Range("a8:g8").Value = Worksheets(myNextSheetName).Range("a8:g8").Value
Worksheets("カレンダー").Range("a11:g11").Value = Worksheets(myNextSheetName).Range("a11:g11").Value
Worksheets("カレンダー").Range("a14:g14").Value = Worksheets(myNextSheetName).Range("a14:g14").Value
Worksheets("カレンダー").Range("a17:g17").Value = Worksheets(myNextSheetName).Range("a17:g17").Value
Worksheets("カレンダー").Range("a20:g20").Value = Worksheets(myNextSheetName).Range("a20:g20").Value
'翌月のワークシートを非表示
Worksheets(myNextSheetName).Visible = False
'翌月のカレンダーに移動
Worksheets("カレンダー").Range("C1").Value = Application.WorksheetFunction.EDate(myMonth, 1)
Worksheets("カレンダー").Select
End Sub

変数を設定

最初の２行では、現在表示されている月のシート名を取得しています。

まず変数myMonthで現在のカレンダーの年月を取得しています。例えばC1セルに2020/08/01が格納されていると、その月の予定を転記するためのシート名を作成します。

シート名に「/」は利用できないため、現在の年月のシート名は「20200801」としています。

２行目の「Replace関数」では、「2020/08/01」の「/」を消去した「20200801」を現在の月のシート名であるmySheetNameという変数に格納しています。

myMonth = Range("c1").Value
mySheetName = Replace(Range("c1").Value, "/", "")

現在の月のシート名がすでにあるかどうかを判定するマクロ

下記のマクロでは、現在の月のシート「20200801」が存在するかどうかを判定しています。

すでにシートが存在すればmyFlagという変数にTrueを、存在しないとFalseとしています。

方法はWorksheets.Countで存在するシートの数だけFor Nextループでチェックし、存在すればmyFlagをTrueにし、存在しなければFalseとしています。

'現在の月のシートがあるか確認
For i = 1 To Worksheets.Count
If Worksheets(i).Name = mySheetName Then
myFlag = True
Exit For
Else
myFlag = False
End If
Next i

現在月のシートが存在しなければ新規にシートを作成

先ほどのFor Nextループで確定させたフラグで、シートがすでに存在すれば何もせず、シートが存在しなければシートを新規に作成します。

If構文でmyFlagがFalse（シートが存在しない）ならば、mySheetNameに格納した名前のシートを最後尾に作成しています（myFlagがTrueならば何もしない）。

'現在の月のシートがなければ新規作成
If myFlag = False Then
Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = mySheetName
End If

現在の月の予定を現在の月シートにコピー

こちらはちょっと力業ですが（笑）、カレンダーの予定を書き込む部分のセルの値をここではmySheetNameである「20200801」シートにコピーをしています。

そして最後に、現在の月のシートを非表示にしています。

'現在の月のデータをコピー
Worksheets(mySheetName).Range("a5:g5").Value = Worksheets("カレンダー").Range("a5:g5").Value
Worksheets(mySheetName).Range("a8:g8").Value = Worksheets("カレンダー").Range("a8:g8").Value
Worksheets(mySheetName).Range("a11:g11").Value = Worksheets("カレンダー").Range("a11:g11").Value
Worksheets(mySheetName).Range("a14:g14").Value = Worksheets("カレンダー").Range("a14:g14").Value
Worksheets(mySheetName).Range("a17:g17").Value = Worksheets("カレンダー").Range("a17:g17").Value
Worksheets(mySheetName).Range("a20:g20").Value = Worksheets("カレンダー").Range("a20:g20").Value
'現在の月のワークシートを非表示
Worksheets(mySheetName).Visible = False

移動する月のシートからデータを読み取る

続いて、移動する月のシートからデータを読み取るマクロです。

移動先の月のシートの名前を計算から求める

まず始めに、翌月のシート名をmyNextSheetNameという変数に格納します。

myNextSheetNameは、mySheetNameに100を足すだけで翌月になります（20200901-20200801=100）。

ただし、12月から翌月に移動する場合は注意が必要ですので、IF Else End If構文で条件分岐をしています。

例として20210101-20201201=8900となりますので、12月からの移動の場合は8900を加算しています。

またTrim関数は、計算によって発生する余分なスペースを取り除く関数です。

'翌月のシートがあるか確認
'12月の場合に注意
If Right(mySheetName, 4) = "1201" Then
myNextSheetName = Trim(mySheetName + 8900)
Else
myNextSheetName = Trim(mySheetName + 100)
End If

移動先の月のシートがなければ新規作成

そしてmySheetNameと同様に、移動先の月のシートmyNextSheetNameがすでに存在するかどうかを判定し、なければ翌月のシートを、シート名mySheetNameとして新規作成します。

For i = 1 To Worksheets.Count
If Worksheets(i).Name = myNextSheetName Then
myFlag = True
Exit For
Else
myFlag = False
End If
Next i
'翌月のシートがなければ新規作成
If myFlag = False Then
Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = myNextSheetName
End If

移動先の月シートからデータを読み込む

移動する先のシートからデータを読み込みます。こちらも力業です。

そして移動先の月データを含んだシート（myNextSheetName）を非表示にした後、EDATE関数によってC1セルの月を一つ増やしています。

さらに最後に、念のためシート「カレンダー」を選択するマクロを記述しています。

'翌月のデータをカレンダーにコピー
Worksheets("カレンダー").Range("a5:g5").Value = Worksheets(myNextSheetName).Range("a5:g5").Value
Worksheets("カレンダー").Range("a8:g8").Value = Worksheets(myNextSheetName).Range("a8:g8").Value
Worksheets("カレンダー").Range("a11:g11").Value = Worksheets(myNextSheetName).Range("a11:g11").Value
Worksheets("カレンダー").Range("a14:g14").Value = Worksheets(myNextSheetName).Range("a14:g14").Value
Worksheets("カレンダー").Range("a17:g17").Value = Worksheets(myNextSheetName).Range("a17:g17").Value
Worksheets("カレンダー").Range("a20:g20").Value = Worksheets(myNextSheetName).Range("a20:g20").Value
'翌月のワークシートを非表示
Worksheets(myNextSheetName).Visible = False
'翌月のカレンダーに移動
Worksheets("カレンダー").Range("C1").Value = Application.WorksheetFunction.EDate(myMonth, 1)
Worksheets("カレンダー").Select

これでほぼ完成です。あとは上記のマクロをコピーして微調整するだけです。

ひと月前に戻るボタンのマクロはコピー＆微調整で簡単に

ひと月前に戻るボタンは、先ほど完成した「Sub ボタン3_Click()」のマクロ部分をコピーして、微調整するだけです。

以下に示しています。変更箇所は赤字にしてあります。

変更点は3か所です。

ただし今度は前月に戻るマクロですから、シートが1月の場合の条件分岐に注意が必要です。

Sub ボタン4_Click()
myMonth = Range("c1").Value
mySheetName = Replace(Range("c1").Value, "/", "")
Dim myFlag As Boolean
'現在の月のシートがあるか確認
For i = 1 To Worksheets.Count
If Worksheets(i).Name = mySheetName Then
myFlag = True
Exit For
Else
myFlag = False
End If
Next i
'現在の月のシートがなければ新規作成
If myFlag = False Then
Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = mySheetName
End If
'現在の月のデータをコピー
Worksheets(mySheetName).Range("a5:g5").Value = Worksheets("カレンダー").Range("a5:g5").Value
Worksheets(mySheetName).Range("a8:g8").Value = Worksheets("カレンダー").Range("a8:g8").Value
Worksheets(mySheetName).Range("a11:g11").Value = Worksheets("カレンダー").Range("a11:g11").Value
Worksheets(mySheetName).Range("a14:g14").Value = Worksheets("カレンダー").Range("a14:g14").Value
Worksheets(mySheetName).Range("a17:g17").Value = Worksheets("カレンダー").Range("a17:g17").Value
Worksheets(mySheetName).Range("a20:g20").Value = Worksheets("カレンダー").Range("a20:g20").Value
'翌月のシートがあるか確認
'1月の場合に注意
If Right(mySheetName, 4) = "0101" Then
myNextSheetName = Trim(mySheetName - 8900)
Else
myNextSheetName = Trim(mySheetName - 100)
End If
For i = 1 To Worksheets.Count
If Worksheets(i).Name = myNextSheetName Then
myFlag = True
Exit For
Else
myFlag = False
End If
Next i
'翌月のシートがなければ新規作成
If myFlag = False Then
Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = myNextSheetName
End If
'翌月のデータをカレンダーにコピー
Worksheets("カレンダー").Range("a5:g5").Value = Worksheets(myNextSheetName).Range("a5:g5").Value
Worksheets("カレンダー").Range("a8:g8").Value = Worksheets(myNextSheetName).Range("a8:g8").Value
Worksheets("カレンダー").Range("a11:g11").Value = Worksheets(myNextSheetName).Range("a11:g11").Value
Worksheets("カレンダー").Range("a14:g14").Value = Worksheets(myNextSheetName).Range("a14:g14").Value
Worksheets("カレンダー").Range("a17:g17").Value = Worksheets(myNextSheetName).Range("a17:g17").Value
Worksheets("カレンダー").Range("a20:g20").Value = Worksheets(myNextSheetName).Range("a20:g20").Value
'翌月のカレンダーに移動
Worksheets("カレンダー").Range("C1").Value = Application.WorksheetFunction.EDate(myMonth, -1)
Worksheets("カレンダー").Select
End Sub

1年後に進む・1年前に戻るマクロもコピー＆微調整で簡単に

ここまでくれば1年後に進む・1年前に戻るは非常に簡単です。12月や1月の判定も不要です。単純に12か月を足すまたは引く計算になります。

1年後に進むマクロ

まずは1年後に進むボタンからです。注意点は赤字にしています。意味はもうお分かりいただけると思います。

具体的には、myNextSheetNameに10000を足すことと、EDATE関数の引数を12にします。

Sub ボタン5_Click()
myMonth = Range("c1").Value
mySheetName = Replace(Range("c1").Value, "/", "")
Dim myFlag As Boolean
'現在の月のシートがあるか確認
For i = 1 To Worksheets.Count
If Worksheets(i).Name = mySheetName Then
myFlag = True
Exit For
Else
myFlag = False
End If
Next i
'現在の月のシートがなければ新規作成
If myFlag = False Then
Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = mySheetName
End If
'現在の月のデータをコピー
Worksheets(mySheetName).Range("a5:g5").Value = Worksheets("カレンダー").Range("a5:g5").Value
Worksheets(mySheetName).Range("a8:g8").Value = Worksheets("カレンダー").Range("a8:g8").Value
Worksheets(mySheetName).Range("a11:g11").Value = Worksheets("カレンダー").Range("a11:g11").Value
Worksheets(mySheetName).Range("a14:g14").Value = Worksheets("カレンダー").Range("a14:g14").Value
Worksheets(mySheetName).Range("a17:g17").Value = Worksheets("カレンダー").Range("a17:g17").Value
Worksheets(mySheetName).Range("a20:g20").Value = Worksheets("カレンダー").Range("a20:g20").Value
'翌月のシートがあるか確認
myNextSheetName = Trim(mySheetName + 10000)
For i = 1 To Worksheets.Count
If Worksheets(i).Name = myNextSheetName Then
myFlag = True
Exit For
Else
myFlag = False
End If
Next i
'翌月のシートがなければ新規作成
If myFlag = False Then
Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = myNextSheetName
End If
'翌月のデータをカレンダーにコピー
Worksheets("カレンダー").Range("a5:g5").Value = Worksheets(myNextSheetName).Range("a5:g5").Value
Worksheets("カレンダー").Range("a8:g8").Value = Worksheets(myNextSheetName).Range("a8:g8").Value
Worksheets("カレンダー").Range("a11:g11").Value = Worksheets(myNextSheetName).Range("a11:g11").Value
Worksheets("カレンダー").Range("a14:g14").Value = Worksheets(myNextSheetName).Range("a14:g14").Value
Worksheets("カレンダー").Range("a17:g17").Value = Worksheets(myNextSheetName).Range("a17:g17").Value
Worksheets("カレンダー").Range("a20:g20").Value = Worksheets(myNextSheetName).Range("a20:g20").Value
'翌月のカレンダーに移動
Worksheets("カレンダー").Range("C1").Value = Application.WorksheetFunction.EDate(myMonth, 12)
Worksheets("カレンダー").Select
End Sub

1年前に戻るマクロ

1年前に戻るマクロも、mySheetNameに10000を引き、EDATE関数の引数を-12とするだけです。

Sub ボタン6_Click()
myMonth = Range("c1").Value
mySheetName = Replace(Range("c1").Value, "/", "")
Dim myFlag As Boolean
'現在の月のシートがあるか確認
For i = 1 To Worksheets.Count
If Worksheets(i).Name = mySheetName Then
myFlag = True
Exit For
Else
myFlag = False
End If
Next i
'現在の月のシートがなければ新規作成
If myFlag = False Then
Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = mySheetName
End If
'現在の月のデータをコピー
Worksheets(mySheetName).Range("a5:g5").Value = Worksheets("カレンダー").Range("a5:g5").Value
Worksheets(mySheetName).Range("a8:g8").Value = Worksheets("カレンダー").Range("a8:g8").Value
Worksheets(mySheetName).Range("a11:g11").Value = Worksheets("カレンダー").Range("a11:g11").Value
Worksheets(mySheetName).Range("a14:g14").Value = Worksheets("カレンダー").Range("a14:g14").Value
Worksheets(mySheetName).Range("a17:g17").Value = Worksheets("カレンダー").Range("a17:g17").Value
Worksheets(mySheetName).Range("a20:g20").Value = Worksheets("カレンダー").Range("a20:g20").Value
'翌月のシートがあるか確認
myNextSheetName = Trim(mySheetName - 10000)
For i = 1 To Worksheets.Count
If Worksheets(i).Name = myNextSheetName Then
myFlag = True
Exit For
Else
myFlag = False
End If
Next i
'翌月のシートがなければ新規作成
If myFlag = False Then
Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = myNextSheetName
End If
'翌月のデータをカレンダーにコピー
Worksheets("カレンダー").Range("a5:g5").Value = Worksheets(myNextSheetName).Range("a5:g5").Value
Worksheets("カレンダー").Range("a8:g8").Value = Worksheets(myNextSheetName).Range("a8:g8").Value
Worksheets("カレンダー").Range("a11:g11").Value = Worksheets(myNextSheetName).Range("a11:g11").Value
Worksheets("カレンダー").Range("a14:g14").Value = Worksheets(myNextSheetName).Range("a14:g14").Value
Worksheets("カレンダー").Range("a17:g17").Value = Worksheets(myNextSheetName).Range("a17:g17").Value
Worksheets("カレンダー").Range("a20:g20").Value = Worksheets(myNextSheetName).Range("a20:g20").Value
'翌月のカレンダーに移動
Worksheets("カレンダー").Range("C1").Value = Application.WorksheetFunction.EDate(myMonth, -12)
Worksheets("カレンダー").Select
End Sub

以上で、予定を書き込むことができる、エクセルの万年カレンダーとなります。

今回はマクロの講座というよりも発想の賜物かもしれません。カレンダーだけではなく他にも応用が利くのではないでしょうか。

不明な点があればコメントいただけたらご回答いたします。

追記：ここまで記事にしておいてなんなんですが、このカレンダーは完成品ではありません。

と言うのも、当該月以外の日付に予定を入れることはできますが、翌月になると表示できません。

翌月に移動すると、下図のように9月30日の予定は表示されなくなります。

こちらについては、後日「完全版」を投稿いたします。

追記：完全版を作成しました。下記の記事をご覧ください。