年間予定表を作成する

一年の計は元旦にあり

ということで
元旦からは少し経ってしまいましたが
年間予定表をVBAで作成したいと思います。

1年間を1枚の紙に表すのに
左から右へ1月から12月までの月を、
上から下へ1日から月末までの日を配置します。

日付の表示は、日付（曜日）になっていますが
セルには日付型の数値が入っていますので
フォーマットを変更するだけで
表示の仕方を変更できます。

祝日の取得は
以前の記事「 任意の年の祝日を取得する 」を参照してください。

大体A3サイズに入る大きさにしました。

コードはこちら

Sub macro110115a()
'MyYear年間予定表
   
    Const MyYear As Integer = 2011
   
    '祝日をWebから取得
    '参照https://yumem.cocolog-nifty.com/blog/2010/03/post-f84a.html
    Call GetHollydays(MyYear)
   
    Dim DAY1 As Date, DAY2 As Date
    Dim SPAN As Integer
    Dim i As Integer, j As Integer, k As Integer
    Dim obj As Object
   
    Sheets.Add
    Cells(1, 1) = MyYear & "年　予定表"
    Cells(1, 1).Font.Size = 24
   
    For i = 1 To 12
        DAY1 = MyYear & "/" & i & "/01" '月始め
        DAY2 = DateAdd("m", 1, DAY1) - 1 '月末
       
        Cells(2, i * 2 - 1) = i & "月"
        Cells(2, i * 2 - 1).Font.Size = 16
        With Range(Cells(2, i * 2 - 1), Cells(2, i * 2))
            .Merge
            .HorizontalAlignment = xlCenter
        End With
       
        '日付の列の幅
        Columns(i * 2 - 1).ColumnWidth = 5.5
        '隣の空白の列の幅
        Columns(i * 2).ColumnWidth = 9
       
        SPAN = DAY2 - DAY1 + 1 'i月の日数
       
        For j = 0 To SPAN - 1
            Set obj = Range(toA1("R" & j + 3 & "C" & i * 2 - 1 & _
                ":R" & j + 3 & "C" & i * 2))
            
            'i月j日のセルとその隣の装飾指定
            obj.Borders.LineStyle = xlContinuous
            obj.Borders.Weight = xlThin
            obj.Borders.ColorIndex = 1
            
            'i月j日のセルの装飾指定
            With Cells(j + 3, i * 2 - 1)
                .Value = DAY1 + j
                .NumberFormat = "d(aaa)"
                .Borders(xlEdgeRight).LineStyle = xlNone
                .VerticalAlignment = xlTop
               
                '土日色づけ
                If Weekday(.Value) = 1 Then
                    '日曜日
                    .Interior.ColorIndex = 38
                    Cells(j + 3, i * 2).Interior.ColorIndex = 38
                ElseIf Weekday(.Value) = 7 Then
                    '土曜日
                    .Interior.ColorIndex = 37
                    Cells(j + 3, i * 2).Interior.ColorIndex = 37
                End If
            End With
            
        Next j
    Next i
   
    '全体の行の高さ指定
    Rows("3:" & Range("A2").End(xlDown).Row).RowHeight = 24
   
    '祝日を追加
    Dim SheetA As Worksheet
    Set SheetA = Sheets("祝日" & MyYear)
    For i = 3 To SheetA.Range("A1").End(xlDown).Row
        Set obj = SheetA.Cells(i, 1)
       
        '祝日に該当する日付のセルの色づけ
        Cells(Day(obj) + 2, Month(obj) * 2 - 1).Interior.ColorIndex = 38
       
        '空白のセルに祝日の名称をいれ装飾
        With Cells(Day(obj) + 2, Month(obj) * 2)
            .Interior.ColorIndex = 38
            .Value = SheetA.Cells(i, 2)
            .Font.Size = 7
            .VerticalAlignment = xlTop
        End With
    Next i
   
End Sub

macro110115a実行後のシートの一部

これをA3用紙に印刷してみましたが
ちょっと小さいですね。
余白を最小限にしてA3で印刷すれば
２、３個の予定が書けます。

この土日はセンター試験ですね。
今年はどんなプログラム問題ですかね～