1. Home »
2. Excel VBA入門:目次 »
3. 指定年月日からの横型の年間カレンダーを作成する

指定年月日からの横型の年間カレンダーを作成する 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

スポンサードリンク
(追記) (追記ここまで)

PageViewCounter
Counter
Since2006/2/27