1. Home »
2. Excel VBA入門:目次 »
3. カレンダーを1週間単位で色分けする

指定年月日からの横型の年間カレンダーを1週間単位で色分けする topへ

• 掲示板にて、12月21日始まりの横型の年間カレンダーの作り方に関連し、1週間単位で塗りつぶしたいとの要望がありました。
  • 元になるカレンダーは 指定年月日からの横型の年間カレンダーを作成する を利用して作成しています。
    行間は「4」として、日付の下2行を1週間単位で塗りつぶす例です。
  • 完成例です
    • E2セルに開始日を入力して、VBAを動かすと横型のカレンダーが1週間単位で色分けします。
    • E3セルの終了日は =DATE(YEAR(E2)+1,MONTH(E2),DAY(E2)-1) としています。
    • O1セルは =TEXT(E3,"ggge")& "年度 カレンダー" としています。
    • 日付の部分(6行目など)は表示形式を d として、日にちだけを表示するように設定しています。
    
    
    
• コードの作成例です。
  • 【例】
    • 日曜日から土曜日までを一週としています。
      順次表示していますので、画面表示の更新を止めて処理しています。
      Application.ScreenUpdating = False の部分です。コードの終了時には Trueに戻しています。
    • 色はRGBの値で指定していますので、Excel2007以降を対象と考えています。
      Excel2003以前ではカラーパレットの色に近い色に置き換えられますのでご注意ください。
    Sub week_color()
    Dim sh1 As Worksheet
    Dim i As Integer, j As Integer
    Dim myPs As Range
    Dim stRange As Range, endRange As Range
    Dim myFlag As Boolean
    Dim r, g, b
    Dim myColor As Integer
    Dim endDay As Integer
    
    ’色をRGBで指定するためにそれぞれのセットで10組準備しています
    r = Array(255, 220, 242, 235, 228, 218, 253, 221, 184, 230, 216)
    g = Array(255, 230, 220, 241, 223, 238, 233, 217, 204, 184, 228)
    b = Array(255, 241, 219, 222, 236, 243, 217, 196, 228, 183, 188)
    
    
    Set sh1 = Worksheets("チェックカレンダー")
    
    With sh1
    .Range("E6:AI53").Interior.ColorIndex = xlNone
    myColor = 1
    myFlag = False
    endDay = Day(.Range("E2").Value - 1)
    
    For i = 8 To 52 Step 4
    myFlag = False
    For j = 5 To 35
    Set myPs = .Cells(i, j)
    
    ’カレンダーの開始日のみはスタート位置として設定する
    If j = 5 Then
    Set stRange = myPs
    End If
    
    ’土曜日を終了位置として設定
    If myPs.Offset(-1, 0) = "土" Then
    Set endRange = myPs.Offset(1, 0)
    myFlag = True
    End If
    
    ’日曜日を開始位置として設定
    If myPs.Offset(-1, 0) = "日" Then
    If myColor = 10 Then myColor = 0
    myColor = myColor + 1
    Set stRange = myPs
    End If
    
    If Day(myPs.Offset(-2, 0).Value) = endDay Then
    Set endRange = myPs.Offset(1, 0)
    myFlag = True
    End If
    
    ’塗りつぶしを実行
    If myFlag = True Then
    .Range(stRange, endRange).Interior.Color = RGB(r(myColor), g(myColor), b(myColor))
    myFlag = False
    If Day(myPs.Offset(-2, 0).Value) = endDay Then Exit For
    End If
    
    Next j
    
    Next i
    
    End With
    
    End Sub

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

PageViewCounter
Counter
Since2006/2/27