指定年月日からの横型の年間カレンダーを作成する:Excel VBA入門

スポンサードリンク

指定年月日からの横型の年間カレンダーを作成する　　　 topへ

掲示板にて、12月21日始まりの横型の年間カレンダーの作り方の質問がありました。
- 完成例です
  - E2セルに開始日を入力して、VBAを動かすと横型のカレンダーが1年分作成できます。
  - E3セルの終了日は　=DATE(YEAR(E2)+1,MONTH(E2),DAY(E2)-1) としています。
  - O1セルは　=TEXT(E3,"ggge")& "年度　カレンダー" としています。
  - 日付の部分(6行目など）は表示形式を　d　として、日にちだけを表示するように設定しています。

コードの作成例です。

【例】
- このコードは1月～12月をループして「カレンダー」シートに書き出しています。
  各月の最後(各行の最後)は終了日と同じ日にちである時であり、そこで次の月(次の行)に移るといった動作になっています。
- なお、各日にちなどを順次表示していますので、画面表示の更新を止めて処理しています。
  Application.ScreenUpdating = False　の部分です。コードの終了時には　Trueに戻しています。
- 4行おきに書き出すためにgyokan = 4　としています。4の部分を書き換えることで間隔を変えることができます。
- 祝祭日の判定は「祝日」シートのA列に祝祭日を入力してあり、ここを参照しています。
  下図が入力例です。
  - 下表には間違いがあり、2012/12/24の振替休日が抜けています。

このコードでは基準となるセル位置をSet myPs・・・　といった具合に設定して処理を行っています。
コード内ではmyPsに注意してみていただくと処理方法が理解しやすいと考えます。
ループを抜ける条件など、コードを修正しました(2013/6/21)
月の表示を変更しました。(2017/5/12)

Sub calendar_make2()
'カレンダー作成
'
　　Dim sh1 As Worksheet
　　Dim i As Integer, j As Integer
　　Dim myDay As Date
　　Dim myPs As Range
　　Dim Holiday As Range
　　Dim iCol As Variant, fCol As Variant
　　Dim myFlg As Boolean
　　Dim sYear As Integer, eYear As Integer
　　Dim sMonth As Integer, eMonth As Integer
　　Dim sDay As Integer, eDay As Integer
　　 Dim gyokan As Long, mycnt As Long

　　Set sh1 = Worksheets("カレンダー")　'カレンダーを作成するシートを sh1　としています
　　Set Holiday = Worksheets("祝日").Range("A1:A84")　'祝日が入力されている範囲の値を配列に読み込んでいます

　　Application.ScreenUpdating = False　'画面の自動更新を停止します
　　
　　gyokan = 4　’行間隔を 4 としています

　　With sh1
　　　　'値、セルの塗りつぶしの色　フォントの色をクリアします
　　　　With .Range("D4:AI100")　'とりあえず100行目までを設定範囲として考えています。
　　　　　　.ClearContents
　　　　　　.Interior.ColorIndex = xlNone
　　　　　　.Font.ColorIndex = 0
　　　　End With

　　　　'設定年月日
　　　　　　sYear = Year(.Range("E2").Value)　'開始年月日の年
　　　　　　sMonth = Month(.Range("E2").Value)　'開始年月日の月
　　　　　　sDay = Day(.Range("E2").Value)　'開始年月日の日
　　　　　　eYear = Year(.Range("E3").Value)　'終了年月日の年
　　　　　　eMonth = Month(.Range("E3").Value)　'終了年月日の月
　　　　　　eDay = Day(.Range("E3").Value)　'終了年月日の日

　　　　For i = 1 To 12　’月単位でループ
　　　　　　For j = 1 To 32　'日単位でループ
　　　　　　　　’入力する日付
　　　　　　　　myDay = DateSerial(sYear, sMonth - 1 + i, sDay - 1 + j)　'開始年月日に i 月と j 日を1づつ加算する

　　　　　　　　 'ループを抜ける条件
　　　　　　　　　If Day(myDay) = sDay Then
　　　　　　　　　　　myCnt = myCnt + 1
　　　　　　　　　　　　　If myCnt = 2 Then
　　　　　　　　　　　　　　　myCnt = 0
　　　　　　　　　　　　　　　Exit For
　　　　　　　　　　　　　End If
　　　　　　　　　End If

　　　　　　　　　'終了日になったら終了する
　　　　　　　　　If myDay > DateSerial(eYear, eMonth, eDay) Then
　　　　　　　　　　　Application.ScreenUpdating = True
　　　　　　　　　　　End
　　　　　　　　　End If

　　　　　　　　'月、日にちをセルに入力する
　　　　　　　　.Cells(2 + gyokan * i, 4).Value = Month(.Cells(2 + gyokan * i, 5).Value) & "月"　'月を入力
　　　　　　　　.Cells(2 + gyokan * i + 1, 4).Value = "曜日"　'文字"曜日"を入力
　　　　　　　　　'入力するセルを指定 Cell(2+4*1,4+1)=Cell(6,5)　つまり　E6セルを開始セルとしています
　　　　　　　　　' これに　i　と j　を加えて入力セル位置が指定されます
　　　　　　　　Set myPs = .Cells(2 + gyokan * i, 4 + j)　
　　　　　　　　myPs.Value = myDay
　　　　　　　　myPs.NumberFormatLocal = "d"　　'表示形式を"d"に設定しています。

　　　　　　　　'曜日を入力
　　　　　　　　myPs.Offset(1, 0).Value = Format(myDay, "aaa")
　　　　　　　　'土日check
　　　　　　　　myFlg = False
　　　　　　　　Select Case myPs.Offset(1, 0).Value
　　　　　　　　　　Case "土"
　　　　　　　　　　　　iCol = 34　　’塗りつぶしの色番号
　　　　　　　　　　　　fCol = 5　　'フォントの色番号
　　　　　　　　　　　　myFlg = True
　　　　　　　　　　Case "日"
　　　　　　　　　　　　iCol = 36
　　　　　　　　　　　　fCol = 3
　　　　　　　　　　　　myFlg = True
　　　　　　　　　　End Select

　　　　　　　　　'祝日check
　　　　　　　　　If WorksheetFunction.CountIf(Holiday, myPs.Value) = 1 Then
　　　　　　　　　　　iCol = 40
　　　　　　　　　　　fCol = 3
　　　　　　　　　　　myFlg = True
　　　　　　　　　End If
　　　　　　　　　'着色　　土日祝日の時(myFlg = True)に実行
　　　　　　　　　If myFlg = True Then
　　　　　　　　　　.Range(myPs, myPs.Offset(1, 0)).Interior.ColorIndex = iCol
　　　　　　　　　　.Range(myPs, myPs.Offset(1, 0)).Font.ColorIndex = fCol
　　　　　　　　　End If

　　　　　　　Next j

　　　　　　Next i

　　　　End With

　　　　Application.ScreenUpdating = True

End Sub

指定年月日からの縦型の年間カレンダーを作成する　　　 topへ

掲示板にて、縦型のカレンダーを作成したいとの質問がありました。
横に入力していたものを縦に変更しただけですので、基本的なところは同じですので詳細な説明は省略します。
2019年の1/1～12/31の縦型カレンダーです。完成例です。列幅は手動で適当に調整していますことご了承ください。
縦型に変更したために修正したところは下記のような部分です。
カレンダーを作成するシートは　「カレンダー2」としています。
祝祭日の一覧は　「祝日」シートのA1セルから縦に入力します。
E2セルには　「2019/1/1」と入力しています。
E3セルには　=DATE(YEAR(E2)+1,MONTH(E2),DAY(E2)-1)
O1セルには　=TEXT(E3,"ggge")& "年度　カレンダー"
と入力しています。
コード内の変更は
Dim retukan As Long, mycnt As Long
retukan = 4 '列間隔

ここから----
'月、日にちを入力
.Cells(6, retukan * i).Value = Month(.Cells(2, 5).Value) + i - 1 & "月"
.Cells(6, retukan * i + 1).Value = "曜日"

Set myPs = .Cells(6 + j, retukan * i) '入力するセル　ここを基準に設定しています
ここまで----

Offset(1,0)の箇所を↓のように　Offset(0, 1)　と数カ所を変更しています。
myPs.Offset(0, 1).Value = Format(myDay, "aaa")

といったところです。

コード内の変更箇所は紫色の文字色にしています。

Sub calendar_tate()
'カレンダー作成
'
Dim sh1 As Worksheet
Dim i As Integer, j As Integer
Dim myDay As Date
Dim myPs As Range
Dim Holiday As Range
Dim iCol As Variant, fCol As Variant
Dim myFlg As Boolean
Dim sYear As Integer, eYear As Integer
Dim sMonth As Integer, eMonth As Integer
Dim sDay As Integer, eDay As Integer
Dim retukan As Long, mycnt As Long

　Set sh1 = Worksheets("カレンダー2")
　Set Holiday = Worksheets("祝日").Range("A1:A84")

　Application.ScreenUpdating = False

　retukan = 4 '列間隔　'<--変更箇所

With sh1
'着色クリア
　With .Range("D4:AW100") 'とりあえず100行目までを設定範囲として考えています。
　　　.ClearContents
　　　.Interior.ColorIndex = xlNone
　　　.Font.ColorIndex = 0
　End With

'設定年月日
　　sYear = Year(.Range("E2").Value)
　　sMonth = Month(.Range("E2").Value)
　　sDay = Day(.Range("E2").Value)
　　eYear = Year(.Range("E3").Value)
　　eMonth = Month(.Range("E3").Value)
　　eDay = Day(.Range("E3").Value)

For i = 1 To 12
　　For j = 1 To 32
　　　　'入力する日付
　　　　myDay = DateSerial(sYear, sMonth - 1 + i, sDay - 1 + j)

　　　　'ループを抜ける条件
　　　　If Day(myDay) = sDay Then
　　　　　　mycnt = mycnt + 1
　　　　　　If mycnt = 2 Then
　　　　　　　　mycnt = 0
　　　　　　　　Exit For
　　　　　　End If
　　　　End If

　　　　'終了日になったら終了する
　　　　If myDay > DateSerial(eYear, eMonth, eDay) Then
　　　　　　Application.ScreenUpdating = True
　　　　　　End
　　　　End If

　　　　'月、日にちを入力
　　　　.Cells(6, retukan * i).Value = Month(.Cells(2, 5).Value) + i - 1 & "月"
　　　　.Cells(6, retukan * i + 1).Value = "曜日"

　　　　Set myPs = .Cells(6 + j, retukan * i) '入力するセル　ここを基準に設定しています
　　　　myPs.Value = myDay
　　　　myPs.NumberFormatLocal = "d" '表示形式を"d"に設定しています。

　　　'曜日を入力
　　　myPs.Offset(0, 1).Value = Format(myDay, "aaa")
　　　'土日check
　　　myFlg = False
　　　Select Case myPs.Offset(0, 1).Value
　　　　　Case "土"
　　　　　　　iCol = 34 '塗りつぶしの色番号
　　　　　　　fCol = 5 'フォントの色番号
　　　　　　　myFlg = True
　　　　　Case "日"
　　　　　　　iCol = 36
　　　　　　　fCol = 3
　　　　　　　myFlg = True
　　　　　End Select

　　　'祝日check
　　　If WorksheetFunction.CountIf(Holiday, myPs.Value) = 1 Then
　　　　　iCol = 40
　　　　　fCol = 3
　　　　　myFlg = True
　　　End If
　　　'着色　　土日祝日の時(myFlg = True)に実行
　　　If myFlg = True Then
　　　　　.Range(myPs, myPs.Offset(0, 1)).Interior.ColorIndex = iCol
　　　　　.Range(myPs, myPs.Offset(0, 1)).Font.ColorIndex = fCol
　　　End If

　　　Next j

　Next i

End With

Application.ScreenUpdating = True

End Sub

スポンサードリンク

よねさんのWordとExcelの小部屋｜Excel(エクセル)講座の総目次｜Excel(エクセル) VBA入門：目次｜指定年月日からの横型の年間カレンダーを作成する

PageViewCounter
　 Counter
　Since2006/2/27

指定年月日からの横型の年間カレンダーを作成する:Excel VBA入門

指定年月日からの横型の年間カレンダーを作成する topへ

指定年月日からの縦型の年間カレンダーを作成する topへ

指定年月日からの横型の年間カレンダーを作成する　　　 topへ

指定年月日からの縦型の年間カレンダーを作成する　　　 topへ