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

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

月曜始まりのカレンダーを作成する 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
Counter
Since2006/2/27