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

横型カレンダーからボックス型カレンダーを作成する 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
Counter
Since2006/2/27