多年カレンダーの自作

質問

画像のようなシンプルな複数年のカレンダーを任意の期間で作れたらと思っているのですがおすすめのソフトなどあれば教えてください。エクセルでも作れますか？

回答No.1

nishi6 · ベストアンサー

＞おすすめのソフトなどあれば教えてください。
閲覧できる年を指定するものはネットにたくさんあるようです。

＞エクセルでも作れますか？
作ってみました。最初、１ヶ月を関数で作ったんですが、説明が大変で、VBAに変更しました。関数では、コピーできる式を作るのが大変でしょう。何十年分も算式のコピーはしたくないですね。関数では、月初１日の曜日（書き出し位置）、土日の折り返し、前月と当月、翌月の判定など大変です。

VBAで基本的な計算は20～30行ですが、添付図にあるようなデザインに近くするのに50行くらい使ってしまいました。
万年カレンダー＆万年祝日（しょっちゅう変更有り）にしてみましたが、回答に適さないので、祝日表示は省きました。祝日の表示も可能とお伝えしておきます。

新規のExcelブックを開いて、下記マクロを標準モジュールに貼り付けて実行します。「年の開始日」、「表示する年数」を設定してください。今は、「2019」年開始、「20」年間計算です。シート側では何もしません。非力なPCで、100年間の計算が15秒程度でした。当方、Win10、Excel2010です。

Sub myCalendar()
　Dim y As Integer, m As Integer, w As Integer　'// 年,月,週
　Dim drw As Integer　　'// 月の行数

　Const yStart = 2019　'// 年の開始日
　Const yMax = 20　　　'// 表示する年数

　Dim rw As Integer, col As Integer　 '// 行,列カウンタ
　Dim Dt As Date　　　　'// 年月日
　Dim wd1stDay As Date　　 '// 月初の曜日
　Dim prtDay As Integer, varDay As Variant　'// 表示する日

　Application.ScreenUpdating = False
　Cells.Clear
　Rows("1:" & 7 * yMax).Delete Shift:=xlUp

　'// 表題　月と各月の曜日
　With Range("A1")
　　Dim mC As Integer
　　For m = 1 To 12
　　　mC = (m - 1) * 8 + 2
　　　.Offset(0, mC).Value = m
　　　With .Offset(0, mC).Range("A1:G1")
　　　　.HorizontalAlignment = xlCenterAcrossSelection
　　　　.Font.Size = 40
　　　　.Font.Italic = True
　　　End With
　　　.Offset(1, mC).Range("A1:H1") = Split("日,月,火,水,木,金,土, ", ",")
　　　.Offset(1, mC).Range("A1:A" & 7 * yMax).Font.ColorIndex = 3
　　Next
　　.Offset(1, 1) = "　 "
　End With

　'// 年月日
　rw = 2
　With Range("A1")
　　For y = 0 To yMax - 1
　　　Range(.Offset(rw, 0), .Offset(rw, 8 * 12)).Borders(xlEdgeTop).LineStyle = xlContinuous
　　　.Offset(rw, 0) = yStart + y　'// 年
　　　.Offset(rw, 0).Font.Size = 20
　　　With Range(.Offset(rw, 0), .Offset(rw + 2, 0))
　　　　.Merge
　　　　.Borders.LineStyle = xlContinuous
　　　　.Font.Bold = True
　　　End With
　　　With Range(.Offset(rw, 1), .Offset(rw + 2, 1))
　　　　.Merge
　　　　.Borders.LineStyle = xlContinuous
　　　End With

　　　col = 2
　　　For m = 1 To 12
　　　　For drw = 1 To 6
　　　　　wd1stDay = Weekday(DateSerial(yStart + y, m, 1))
　　　　　For w = 1 To 7
　　　　　　Dt = DateSerial(yStart + y, m, (drw - 1) * 7 + w)
　　　　　　If (drw - 1) * 7 + w < wd1stDay Then
　　　　　　　prtDay = 0: varDay = ""
　　　　　　ElseIf (drw - 1) * 7 + w = wd1stDay Then
　　　　　　　prtDay = 1: varDay = 1
　　　　　　ElseIf Month(DateSerial(yStart + y, m, prtDay + 1)) = m Then
　　　　　　　prtDay = prtDay + 1: varDay = prtDay
　　　　　　Else
　　　　　　　varDay = ""
　　　　　　End If
　　　　　　.Offset(rw + drw - 0, col + (m - 1) * 7 + w - 1) = varDay
　　　　　Next
　　　　Next
　　　　col = col + 1
　　　Next
　　　rw = rw + 7
　　Next
　　Range(.Offset(rw, 0), .Offset(rw, 8 * 12)).Borders(xlEdgeTop).LineStyle = xlContinuous
　　Range(.Offset(2, 1), .Offset(rw - 1, 1)).Borders(xlEdgeRight).LineStyle = xlContinuous
　　Range(.Offset(1, 2), .Offset(rw, 8 * 12)).HorizontalAlignment = xlCenter
　End With

　Rows("2:" & rw).EntireRow.AutoFit
　Columns("A:CS").EntireColumn.AutoFit
　Application.ScreenUpdating = True
End Sub

お礼

希望通りのものを作ることができました！！ありがとうございました。