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

カレンダーを1週間単位で色分けする:Excel VBA入門

スポンサードリンク

指定年月日からの横型の年間カレンダーを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
　
　Since2006/2/27