1. Home » 
2. Excel VBA入門：目次 » 
3. シートごとに月別のカレンダーを作成する

シートごとに月別のカレンダーを作成する:Excel VBA入門

• 当サイトの掲示板にて質問があったものです。月ごとのボックスカレンダーを各シートに作成したいとのことでした。

月曜始まりのカレンダーを作成する　　topへ

• 質問のあったカレンダーは月曜日始まりのもので、マスターとなるシートに書式が作成されており、このシートをコピーして各月のシートを作成するというものです。
• 書式として、土曜日の日付は青色、日曜日と祝日は赤色とします。
  祝日はコード内に書いて処理することにしています。
• カレンダー原紙
  • 下図のような枠組みのシートになっています。
    
• 完成図
  • 下図は2014年1月のカレンダーです。シート名は「2014年1月」といった形式で作成します。
    
• コードの作成例です。
  • 作成するカレンダーの年は、コード内に書いています。makeYear = 2014　として、2014年のカレンダーを作成します。

    Sub make_Ca() 　　Dim i As Integer, j As Integer, k As Integer 　　Dim lastDay As Integer 　　Dim makeYear As Integer 　　Dim r As Integer, g As Integer 　　Dim myFlag As Boolean 　　Dim myFlag2 As Boolean 　　Dim syukujitu As Variant 　　Dim sh As Worksheet 　　Dim sh_name As String 　　’作成するカレンダーの年、祝日をここで設定しています。 　　makeYear = 2014 　　syukujitu = Array("2014/1/1", "2014/1/13", "2014/2/11", "2014/3/21", "2014/4/29", "2014/5/3", "2014/5/3", "2014/5/4", "2014/5/5", "2014/5/6", "2014/7/21", "2014/9/15", "2014/9/23", "2014/10/13", "2014/11/3", "2014/11/23", "2014/11/24", "2014/12/23") '今回は2014年のカレンダーを作成するので、以下の2015年用のデータはコメントアウトしています。 ' makeYear = 2015 ' syukujitu = Array("2015/1/1", "2015/1/12", "2015/2/11", "2015/3/21", "2015/4/29", "2015/5/3", "2015/5/4", "2015/5/5", "2015/5/6", "2015/7/20", "2015/9/21", "2015/9/22", "2015/9/23", "2015/10/12", "2015/11/3", "2015/11/23", "2015/12/23") 　　'1月から12月のカレンダーを作成します。 　　For i = 1 To 12 　　'作成する月のシートがあるか否かの存在確認 　　sh_name = makeYear & "年" & i & "月" 　　myFlag2 = False 　　For Each sh In ThisWorkbook.Worksheets 　　　　If sh.Name = sh_name Then 　　　　　　myFlag2 = True 　　　　End If 　　Next sh 　　'月のシートが無かったらカレンダー原紙をコピーして作成する 　　If myFlag2 = False Then 　　　　Worksheets("カレンダー原紙").Copy after:=Worksheets(Worksheets.Count) 　　　　ActiveSheet.Name = sh_name 　　End If 　　’月の末日を計算 　　　lastDay = Day(DateSerial(makeYear, i + 1, 1) - 1) 　　'カレンダーの作成 　　　With Worksheets(makeYear & "年" & i & "月") 　　　　.Cells(1, 1).Value = i & "月日程表" 　　　　myFlag = False 　　　　'日にちを入力 　　　　For j = 1 To lastDay 　　　　　　r = Weekday(DateSerial(makeYear, i, j), vbMonday) 　　　　　　’日にちは1列飛ばしで入力するため、rの値は奇数になるようにしてあります 　　　　　　r = r * 2 - 1 　　　　　　If r = 13 Then myFlag = True 　　　　　　If j = 1 And r = 13 Then g = 6 　　　　　　If myFlag = False Then g = 6 　　　　　　.Cells(g, r).Value = j 　　　　　　'土曜日の日にちは青、日曜日の日にちは赤色にする 　　　　　　If r = 11 Then .Cells(g, r).Font.ColorIndex = 5 　　　　　　If r = 13 Then .Cells(g, r).Font.ColorIndex = 3 　　　　　　'祝日の日にちは赤色にする 　　　　　　For k = LBound(syukujitu) To UBound(syukujitu) 　　　　　　　　　If DateSerial(makeYear, i, j) = DateValue(syukujitu(k)) Then 　　　　　　　　　　　.Cells(g, r).Font.ColorIndex = 3 　　　　　　　　　End If 　　　　　　Next k 　　　　　　　'日曜日を入力したら行の位置を4行下げる 　　　　　　If myFlag = True And r = 13 Then 　　　　　　　　g = g + 4 　　　　　　　　　'ただし、月の末日が日曜のとき以外とする 　　　　　　　　If g = 26 And j <> lastDay Then 　　　　　　　　　　Worksheets("カレンダー原紙").Range("21:25").Copy .Range("25:29") 　　　　　　　　End If 　　　　　　End If 　　　　Next j 　　End With 　　Next i End Sub

日曜始まりのカレンダーを作成する　　topへ

• 上記のコードは月曜始まりのカレンダーでしたが、日曜始まりとしたらどうすればよいのでしょうか?
  1. 元になるカレンダー原紙を下図のように　日曜始まりにします。
     
  2. コードで修正するのは、赤色の3カ所の部分だけです。

     Sub make_Ca() 　　Dim i As Integer, j As Integer, k As Integer 　　Dim lastDay As Integer 　　Dim makeYear As Integer 　　Dim r As Integer, g As Integer 　　Dim myFlag As Boolean 　　Dim myFlag2 As Boolean 　　Dim syukujitu As Variant 　　Dim sh As Worksheet 　　Dim sh_name As String 　　’作成するカレンダーの年、祝日をここで設定しています。 '今回は2015年のカレンダーを作成するので、以下の2014年用のデータはコメントアウトしています。 '　　makeYear = 2014 '　　syukujitu = Array("2014/1/1", "2014/1/13", "2014/2/11", "2014/3/21", "2014/4/29", "2014/5/3", "2014/5/3", "2014/5/4", "2014/5/5", "2014/5/6", "2014/7/21", "2014/9/15", "2014/9/23", "2014/10/13", "2014/11/3", "2014/11/23", "2014/11/24", "2014/12/23") 　　makeYear = 2015 　　syukujitu = Array("2015/1/1", "2015/1/12", "2015/2/11", "2015/3/21", "2015/4/29", "2015/5/3", "2015/5/4", "2015/5/5", "2015/5/6", "2015/7/20", "2015/9/21", "2015/9/22", "2015/9/23", "2015/10/12", "2015/11/3", "2015/11/23", "2015/12/23") 　　'1月から12月のカレンダーを作成します。 　　For i = 1 To 12 　　'作成する月のシートがあるか否かの存在確認 　　sh_name = makeYear & "年" & i & "月" 　　myFlag2 = False 　　For Each sh In ThisWorkbook.Worksheets 　　　　If sh.Name = sh_name Then 　　　　　　myFlag2 = True 　　　　End If 　　Next sh 　　'月のシートが無かったらカレンダー原紙をコピーして作成する 　　If myFlag2 = False Then 　　　　Worksheets("カレンダー原紙").Copy after:=Worksheets(Worksheets.Count) 　　　　ActiveSheet.Name = sh_name 　　End If 　　’月の末日を計算 　　　lastDay = Day(DateSerial(makeYear, i + 1, 1) - 1) 　　'カレンダーの作成 　　　With Worksheets(makeYear & "年" & i & "月") 　　　　.Cells(1, 1).Value = i & "月日程表" 　　　　myFlag = False 　　　　'日にちを入力 　　　　For j = 1 To lastDay 　　　　　　r = Weekday(DateSerial(makeYear, i, j), vbSunday) 　　　　　　’日にちは1列飛ばしで入力するため、rの値は奇数になるようにしてあります 　　　　　　r = r * 2 - 1 　　　　　　If r = 13 Then myFlag = True 　　　　　　If j = 1 And r = 13 Then g = 6 　　　　　　If myFlag = False Then g = 6 　　　　　　.Cells(g, r).Value = j 　　　　　　'土曜日の日にちは青、日曜日の日にちは赤色にする 　　　　　　If r = 13 Then .Cells(g, r).Font.ColorIndex = 5 　　　　　　If r = 1 Then .Cells(g, r).Font.ColorIndex = 3 　　　　　　'祝日の日にちは赤色にする 　　　　　　For k = LBound(syukujitu) To UBound(syukujitu) 　　　　　　　　　If DateSerial(makeYear, i, j) = DateValue(syukujitu(k)) Then 　　　　　　　　　　　.Cells(g, r).Font.ColorIndex = 3 　　　　　　　　　End If 　　　　　　Next k 　　　　　　　'日曜日を入力したら行の位置を4行下げる 　　　　　　If myFlag = True And r = 13 Then 　　　　　　　　g = g + 4 　　　　　　　　　'ただし、月の末日が日曜のとき以外とする 　　　　　　　　If g = 26 And j <> lastDay Then 　　　　　　　　　　Worksheets("カレンダー原紙").Range("21:25").Copy .Range("25:29") 　　　　　　　　End If 　　　　　　End If 　　　　Next j 　　End With 　　Next i End Sub

  3. 日曜日始まりのカレンダーが作成できました。
     

スポンサードリンク

PageViewCounter
　
　Since2006/2/27