1. Home » 
2. Excel VBA入門：目次 » 
3. 横型カレンダーからボックス型カレンダーを作成する

横型カレンダーからボックス型カレンダーを作成する:Excel VBA入門

横型カレンダーからボックス型カレンダーを作成する　　　topへ

• 掲示板にて、12月21日始まりの横型の年間カレンダーの作り方に関連した質問がありました。
  横型カレンダーからボックス型カレンダーを作成したいとの要望がありました。
  • 元になるカレンダーは　指定年月日からの横型の年間カレンダーを作成する　を利用して作成しています。
    行間は「4」として、日付の下2行を1週間単位で塗りつぶす例です。
  • 3行目には「休」または数値が入力され、4行目の「土曜日の日」には週ごとの数値の合計が表示されています。
  • 基になる横型カレンダーは下図のようになっています。
    これから日にち(各月の1行目)と数字の行(各月の3行目)だけをボックスタイプのカレンダーに直そう・・・ということです。
    
  • 完成例
    
• コードの作成例です。
  • 【コード例】(2013/2/11修正しましたが、「休」などの色付けなど対処できていない箇所があります。)
    2017/5/12　月数の表示を変更しました。

    Sub calendar_box() 　　Dim sh1 As Worksheet 　　Dim sh2 As Worksheet 　　Dim i As Integer, j As Integer 　　Dim myData 　　Dim cntWDay As Integer, cntWeek As Integer 　　Dim myPs 　　Dim cntMonth As Integer 　　Dim youbi, saijitu, hiduke, tuki 　　Set sh1 = Worksheets("チェックカレンダー") 　　Set sh2 = Worksheets("年間カレンダー") 　　myData = sh1.Range("E6:AI53").Value 　　'カレンダーの表示位置を指定 　　myPs = Array("C6", "N6", "Y6", "C22", "N22", "Y22", "C38", "N38", "Y38", "C54", "N54", "Y54") 　　'セル範囲をクリアしています 　　sh2.Range("B1:AE84").ClearFormats 　　sh2.Range("B1:AE84").ClearContents 　　For i = 1 To 45 Step 4 　　　　cntMonth = cntMonth + 1 　　　　'1か月単位でデータをboxに入れる 　　　　Dim box(1 To 12, 1 To 7) 　　　　For j = 1 To 31 　　　　　　If j = 1 Then 　　　　　　　　cntWDay = Weekday(myData(i, j)) 　　　　　　　　cntWeek = 1 　　　　　　　　'各月の1行目のデータをboxに入れる 　　　　　　　　box(cntWeek, cntWDay) = myData(i, j) 　　　　　　　　'各月の3行目のデータをboxに入れる 　　　　　　　　box(cntWeek + 1, cntWDay) = myData(i + 2, j) 　　　　　　Else 　　　　　　　　'日曜になると2行下に移るためにカウントアップする 　　　　　　　　If Weekday(myData(i, j)) = 1 Then 　　　　　　　　　　cntWeek = cntWeek + 2 　　　　　　　　End If 　　　　　　　　If myData(i, j) <> "" Then 　　　　　　　　　　cntWDay = Weekday(myData(i, j)) 　　　　　　　　　　box(cntWeek, cntWDay) = myData(i, j) 　　　　　　　　　　box(cntWeek + 1, cntWDay) = myData(i + 2, j) 　　　　　　　　End If 　　　　　　End If 　　　　　　　　　' 表示する月を最初の日にちの月にしています。' 　　　　　　　　　If myData(i, 1) = 0 Then 　　　　　　　　　　　tuki = "" 　　　　　　　　　Else 　　　　　　　　　　　tuki = Month(myData(i, 1)) 　　　　　　　　　End If 　　　　Next j 　　　　sh2.Range(myPs(cntMonth - 1)).Resize(12, 7).Value = box 　　　　 sh2.Range(myPs(cntMonth - 1)).Resize(12, 7).NumberFormatLocal = "d"　’セルの表示形式を"d"に設定しています 　　　　Erase box 　　　　sh2.Range(myPs(cntMonth - 1)).Offset(-2, -1).Value = tuki & "月"　'月の表示です 　　Next i 　　'曜日の設定＆着色 　　　youbi = Array("日", "月", "火", "水", "木", "金", "土") 　　　For i = 0 To UBound(myPs) 　　　　　For j = 0 To 6 　　　　　　　sh2.Range(myPs(i)).Offset(-1, j).Value = youbi(j) 　　　　　Next j 　　　Next i 　　’土日の色付け(土日をチェックしています) 　　　For i = 0 To UBound(myPs) 　　　　　For j = 0 To 6 　　　　　　　If sh2.Range(myPs(i)).Offset(-1, j).Value = youbi(0) Then 　　　　　　　　　sh2.Range(myPs(i)).Offset(-1, j).Resize(13, 1).Font.ColorIndex = 3 　　　　　　　ElseIf sh2.Range(myPs(i)).Offset(-1, j).Value = youbi(6) Then 　　　　　　　　　sh2.Range(myPs(i)).Offset(-1, j).Resize(13, 1).Font.ColorIndex = 5 　　　　　　　End If 　　　　　Next j 　　　Next i 　　’祝日の色付け(祝日を総当たりでチェックしています) 　　Dim k As Long 　　saijitu = Worksheets("祝日").Range("A1:A84").Value 　　hiduke = sh2.Range("A1:AE65").Value 　　　　For i = 1 To 65 　　　　　　For j = 1 To 31 　　　　　　　　For k = 1 To 84 　　　　　　　　　　If hiduke(i, j) = saijitu(k, 1) Then 　　　　　　　　　　　　sh2.Cells(i, j).Font.ColorIndex = 7 　　　　　　　　　　End If 　　　　　　　　Next k 　　　　　　Next j 　　　　Next i End Sub

PageViewCounter
　
　Since2006/2/27