【例】データは配列に入れてシートへ書き出すようにしています。
- 1月〜12月をループしてシートに書き出しています。
そのため配列myTableはその都度設定しクリアしています。
- 10行おきに書き出すためにgyoukan = 10 としています。10の部分を書き換えることで間隔を変えることができます。
- 1904年日付システムでは不具合がありましたのでコードを修正しました。(2011年5月12日)
Sub calendar_year3()
'
'指定日からの年間カレンダー
'
Dim myDate As String
Dim Nen As Integer, Tuki As Integer, hi As Integer
Dim gyoukan As Integer, gyou As Integer
Dim i As Integer, j As Long, k As Integer
Dim cn As Long
Dim c As Range
Dim myTitleD, myTitle(1 To 1, 1 To 7)
'表示行の間隔を指定しています
gyoukan = 10
'作成する年を入力します
myDate = Application.InputBox(Title:="1年間のカレンダー作成", _
Prompt:="作成開始の年月日を2011年1月1日 の形式で入力してください", _
Default:="2011年1月1日", Type:=2)
Nen = Year(myDate)
Tuki = Month(myDate)
hi = Day(myDate)
'曜日のタイトルを配列にセットします
myTitleD = Array("日", "月", "火", "水",
"木", "金", "土")
For k = 0 To 6
myTitle(1, k + 1) = myTitleD(k)
Next k
Range("A:H").Clear
Application.ScreenUpdating = False
'ひと月分の日付を配列にセットして書き出します
For i = Tuki To Tuki + 11
Dim myTable(1 To 6, 1 To 7)
cn = 1
For j = DateSerial(Nen, i, hi) To DateSerial(Nen, i + 1, hi - 1)
If Day(j) <> hi And Weekday(j) = 1 Then cn = cn + 1
myTable(cn, Weekday(j)) = Format(j , "yyyy/m/d")
Next j
'シートに書き出します
gyou = gyou + 1
Range("A" & 1 + gyoukan * (gyou - 1)).Value = DateSerial(Nen,
i, 1)
Range("B" & 2 + gyoukan * (gyou - 1)).Resize(1, 7).Value
= myTitle
Range("B" & 3 + gyoukan * (gyou - 1)).Resize(6, 7).Value
= myTable
'書式を設定します
Range("A" & 1 + gyoukan * (gyou - 1)).NumberFormatLocal
= "yyyy""年""m""月"""
Range("B" & 2 + gyoukan * (gyou - 1)).Resize(7, 7).HorizontalAlignment
= xlCenter
Range("B" & 3 + gyoukan * (gyou - 1)).Resize(6, 7).NumberFormatLocal
= "d"
'日曜日は赤色,土曜日は青色にします
Range("B" & 2 + 10 * (gyou - 1)).Resize(6, 1).Font.Color
= RGB(255, 0, 0)
Range("H" & 2 + 10 * (gyou - 1)).Resize(6, 1).Font.Color
= RGB(0, 0, 255)
'祝日(指定休日)のチェックし、赤色の太文字にします
For Each c In Range("B" & 3 + gyoukan * (gyou - 1)).Resize(6,
7)
'この例では祝日や指定休日のリストがL2:L212に入力してあります
If Application.CountIf(Range("L2:L212"), c.Value) > 0 Then
c.Font.Color = RGB(255, 0, 0)
c.Font.Bold = True
End If
Next c
Erase myTable
Next i
Application.ScreenUpdating = True
End Sub