ExcelVBA自作カレンダーコントロールへ祝日・休日設定する

ExcelVBA自作カレンダーコントロールへ祝日・休日設定する

前回のカレンダー作成のときに書いた「専用シートを作ってフラグを立てといて参照する」というのを、頭の中にせっかく浮かんだんだから、書いてみようかなーと思いました。


前置き

こちらの記事の続きです。

今回は、表示の度に日付の色をリセットするので、フォームでの色設定はデフォルトのままでOKです。

140804-19 140804-20

前回設定したこの手順がいらなくなります。

休日リストをつくる

140807-1

シート名はなんでも良いですが、このように作ってみます。行が月、列が日で31まで。休みにしたい日に 1 を入れてみます。

コード

UserForm2(カレンダーを描いたフォーム)のコード画面に、前回こういうプロシージャを書いているはず。

Private Sub clndr_set() 'カレンダーの作成と表示
  Dim yy As Integer, mm As Integer, i As Integer, n As Integer, endDay As Integer
  
  If Me.ComboBox1 = "" Or Me.ComboBox2 = "" Then Exit Sub '年か月どちらか入ってなければ中止
  yy = Me.ComboBox1 '年
  mm = Me.ComboBox2 '月
   
  For i = 1 To 42 'ラベルの初期化
    Me("Label" & i).Caption = ""
    Me("Label" & i).BackColor = Me.BackColor
  Next
  
  n = Weekday(yy & "/" & mm & "/" & 1) - 1 'その月の1日の曜日番号に、マイナス1したもの
  endDay = Day(DateAdd("d", -1, DateAdd("m", 1, yy & "/" & mm & "/" & "1"))) '月末日の算出
  For i = 1 To endDay
    Me("Label" & i + n).Caption = i '日を入れる
    If CDate(yy & "/" & mm & "/" & i) = the_date Then Me("Label" & i + n).BackColor = RGB(255, 255, 0) 'TextBoxの日と同じなら色をつける
  Next i
End Sub

ここに、以下のハイライト部分を追記します。

Private Sub clndr_set() 'カレンダーの作成と表示
  Dim yy As Integer, mm As Integer, i As Integer, n As Integer, endDay As Integer
  Dim fnd As Range
  
  If Me.ComboBox1 = "" Or Me.ComboBox2 = "" Then Exit Sub '年か月どちらか入ってなければ中止
  yy = Me.ComboBox1 '年
  mm = Me.ComboBox2 '月
   
  For i = 1 To 42 'ラベルの初期化
    Me("Label" & i).Caption = ""
    Me("Label" & i).BackColor = Me.BackColor
    If i Mod 7 = 1 Then '日曜
      Me("Label" & i).ForeColor = RGB(255, 0, 0) '赤
    ElseIf i Mod 7 = 0 Then '土曜
      Me("Label" & i).ForeColor = RGB(0, 0, 255) '青
    Else 'それ以外
      Me("Label" & i).ForeColor = RGB(0, 0, 0) '黒
    End If
  Next
  
  n = Weekday(yy & "/" & mm & "/" & 1) - 1 'その月の1日の曜日番号に、マイナス1したもの
  endDay = Day(DateAdd("d", -1, DateAdd("m", 1, yy & "/" & mm & "/" & "1"))) '月末日の算出
  For i = 1 To endDay
    Me("Label" & i + n).Caption = i '日を入れる
    If CDate(yy & "/" & mm & "/" & i) = the_date Then Me("Label" & i + n).BackColor = RGB(189, 231, 255) 'TextBoxの日と同じなら色をつける
    With Sheets("休日リスト")
      Set fnd = .Range("A2:A1000").Find(yy) '年を検索
      If Not fnd Is Nothing Then '見つかったら
        If .Cells(fnd.Row + mm - 1, i + 2) = 1 Then Me("Label" & i + n).ForeColor = RGB(255, 0, 0) '赤
      End If
    End With
  Next i
End Sub

12~18行目でカレンダーの日付の色をリセットしています。数値を変えれば好きな曜日を好きな色に出来るので、土日休みじゃないお仕事の方にもいいかも。26~31行目が、さっき作ったシートから該当の日付セルを探してフラグが立ってるか参照している部分です。

まず、A列に該当の年があるか探して、見つかった時だけ処理します。該当の行番号は、年の入っていた行 + 月の数字 -1 なので、fnd.Row + mm - 1となり、該当の列番号は、日付の数値 +2(A, B列分) で、i + 2となります。

そこのセルに 1 が入ってたら、この日はお休みなので、ラベルの文字色を赤くします。(29行目)

140807-2

これで走らせると、休日設定した部分が赤くなります。

休日出勤日も設定してみる

ここは祝日休みなんだけど、この土日は稼動日なんだよなー!なんてことも出来ます。

140807-3

さっきは 1 にしてましたが、こんな感じに「休」「出」など好きな文字を入れておいて、

Private Sub clndr_set() 'カレンダーの作成と表示
  Dim yy As Integer, mm As Integer, i As Integer, n As Integer, endDay As Integer
  Dim fnd As Range
  
  If Me.ComboBox1 = "" Or Me.ComboBox2 = "" Then Exit Sub '年か月どちらか入ってなければ中止
  yy = Me.ComboBox1 '年
  mm = Me.ComboBox2 '月
   
  For i = 1 To 42 'ラベルの初期化
    Me("Label" & i).Caption = ""
    Me("Label" & i).BackColor = Me.BackColor
    If i Mod 7 = 1 Then '日曜
      Me("Label" & i).ForeColor = RGB(255, 0, 0) '赤
    ElseIf i Mod 7 = 0 Then '土曜
      Me("Label" & i).ForeColor = RGB(0, 0, 255) '青
    Else 'それ以外
      Me("Label" & i).ForeColor = RGB(0, 0, 0) '黒
    End If
  Next
  
  n = Weekday(yy & "/" & mm & "/" & 1) - 1 'その月の1日の曜日番号に、マイナス1したもの
  endDay = Day(DateAdd("d", -1, DateAdd("m", 1, yy & "/" & mm & "/" & "1"))) '月末日の算出
  For i = 1 To endDay
    Me("Label" & i + n).Caption = i '日を入れる
    If CDate(yy & "/" & mm & "/" & i) = the_date Then Me("Label" & i + n).BackColor = RGB(189, 231, 255) 'TextBoxの日と同じなら色をつける
    With Sheets("休日リスト")
      Set fnd = .Range("A2:A1000").Find(yy) '年を検索
      If Not fnd Is Nothing Then '見つかったら
        If .Cells(fnd.Row + mm - 1, i + 2) = "休" Then Me("Label" & i + n).ForeColor = RGB(255, 0, 0) '赤
        If .Cells(fnd.Row + mm - 1, i + 2) = "出" Then Me("Label" & i + n).ForeColor = RGB(0, 0, 0) '黒
      End If
    End With
  Next i
End Sub

「休」なら赤、「出」なら黒、というように色をつけてあげます。

140807-4

走らせると、こんな感じ。

所感

休日リストのシートはひとつのブックで独立なので、汎用性はありませんねー。少人数、少ブックでやるのなら、って感じでしょうか。自由に設定出来る反面、使い方は限定的になっちゃうかもですが、こういう方法もあるということで。

休日を共有したカレンダーをあちこちで使いたいなら、外部データベース(Accessとか)に休日フラグのテーブルを持たせてそこを読み込んで、って感じのほうが使い勝手はいいと思います。

公開日:2014/08/07

11件のコメント

  1. teru より:

    休日リストのA列にだけ日付を入れて休日指定したいのですが
    どのようにしたら良いかご教示頂けますでしょうか?

    • *you より:

      teruさん、コメントありがとうございます。「休日リスト」シートから休日を検索する部分を、

      With Sheets("休日リスト")
        Set fnd = .Columns("A").Find(CDate(yy & "/" & mm & "/" & i)) '検索
        If Not fnd Is Nothing Then '見つかったら
          Me("Label" & i + n).ForeColor = RGB(255, 0, 0) '赤
        End If
      End With
      

      こうすればいいんじゃないかなーと思います。

  2. teru より:

    ありがとうございます。
    ちょっと気になる点がありまして、コンボボックスで西暦を手入力すると
    追加したSet fndの行でエラーになってしまいます。
    使用には差し支えないのですが何がいけないのでしょうか?
    DLした方は問題ないです(4桁まで)

    • *you より:

      ああー、コンボボックスの手入力は考えてなかったです。.Findは日付の検索に不安定な動きをすることがあるので、それかもしれませんね。A列の最終端を取得して、ループで回すほうが確実かもしれません。

      昔書いたコードなので宣言とかイケてないなと思って、プロシージャごと書き直してみました。

      Private Sub clndr_set() 'カレンダーの作成と表示
        Dim i As Integer
        Dim ws As Worksheet: Set ws = Sheets("休日リスト")
        
        If Me.ComboBox1 = "" Or Me.ComboBox2 = "" Then Exit Sub '年か月どちらか入ってなければ中止
        Dim yy As Integer: yy = Me.ComboBox1 '年
        Dim mm As Integer: mm = Me.ComboBox2 '月
          
        For i = 1 To 37 'ラベルの初期化
          Me("Label" & i).Caption = ""
          Me("Label" & i).BackColor = Me.BackColor
          If i Mod 7 = 1 Then '日曜
            Me("Label" & i).ForeColor = RGB(255, 0, 0) '赤
          ElseIf i Mod 7 = 0 Then '土曜
            Me("Label" & i).ForeColor = RGB(0, 0, 255) '青
          Else 'それ以外
            Me("Label" & i).ForeColor = RGB(0, 0, 0) '黒
          End If
        Next
        
        Dim n As Integer: n = Weekday(yy & "/" & mm & "/" & 1) - 1 'その月の1日の曜日番号に、マイナス1したもの
        Dim endDay As Integer: endDay = Day(DateAdd("d", -1, DateAdd("m", 1, yy & "/" & mm & "/" & "1"))) '月末日の算出
        Dim lastRow As Long: lastRow = ws.Cells(Rows.Count, 1).End(xlUp).Row '休日リストの最終行
        Dim holiRow As Long
        
        For i = 1 To endDay
          Me("Label" & i + n).Caption = i '日を入れる
          If CDate(yy & "/" & mm & "/" & i) = clndr_date Then Me("Label" & i + n).BackColor = RGB(200, 200, 200) 'TextBoxの日と同じなら色をつける
          For holiRow = 1 To lastRow
            If ws.Cells(holiRow, 1) = CDate(yy & "/" & mm & "/" & i) Then '見つかったら
              Me("Label" & i + n).ForeColor = RGB(255, 0, 0) '赤
              Exit For
            End If
          Next holiRow
        Next i
      End Sub
      

      これで動くと思います。ただ、コンボボックスに4桁より大きい数値を入れるとか、文字列入れちゃうとか、そういうエラー処理はしておりませんのでご了承ください。

  3. teru より:

    教えて頂きましたコードにて業務で使える最高の
    カレンダーツールとなりました。
    分かりやすくてとても参考になります。
    ありがとうございました。

  4. Mimi より:

    とても分かりやすいご説明で、助かりました。form1をアレンジし、オプションボタンとコマンドボタン、フレームで、異なる国のカレンダーを表示できるようになりました。気になるのは、祝日のフォントのみ太字にどうにか設定できないかな、ラベルクリックで何の祝日なのかを表示できないかと模索しています。

    • *you より:

      Mimiさん、コメントありがとうございます。本文中に示したマトリクス状の「休日リスト」で、休日のセルに「1」の代わりに「祝日の名称」が入っているものと仮定すると、こんな感じでしょうか。

      Private Sub clndr_set() 'カレンダーの作成と表示
        Dim i As Integer
        Dim ws As Worksheet: Set ws = Sheets("休日リスト")
        
        If Me.ComboBox1 = "" Or Me.ComboBox2 = "" Then Exit Sub '年か月どちらか入ってなければ中止
        Dim yy As Integer: yy = Me.ComboBox1 '年
        Dim mm As Integer: mm = Me.ComboBox2 '月
          
        For i = 1 To 37 'ラベルの初期化
          Me("Label" & i).Caption = ""
          Me("Label" & i).BackColor = Me.BackColor
          Me("Label" & i).Bold = False
          Me("Label" & i).Tag = ""
          If i Mod 7 = 1 Then '日曜
            Me("Label" & i).ForeColor = RGB(255, 0, 0) '赤
          ElseIf i Mod 7 = 0 Then '土曜
            Me("Label" & i).ForeColor = RGB(0, 0, 255) '青
          Else 'それ以外
            Me("Label" & i).ForeColor = RGB(0, 0, 0) '黒
          End If
        Next
        
        Dim n As Integer: n = Weekday(yy & "/" & mm & "/" & 1) - 1 'その月の1日の曜日番号に、マイナス1したもの
        Dim endDay As Integer: endDay = Day(DateAdd("d", -1, DateAdd("m", 1, yy & "/" & mm & "/" & "1"))) '月末日の算出
        
        For i = 1 To endDay
          Me("Label" & i + n).Caption = i '日を入れる
          If CDate(yy & "/" & mm & "/" & i) = clndr_date Then Me("Label" & i + n).BackColor = RGB(200, 200, 200) 'TextBoxの日と同じなら色をつける
          Dim fnd As Range: Set fnd = ws.Range("A2:A1000").Find(yy) '年を検索
          If Not fnd Is Nothing Then '見つかったら
            If ws.Cells(fnd.Row + mm - 1, i + 2) <> "" Then
              Me("Label" & i + n).ForeColor = RGB(255, 0, 0) '赤
              Me("Label" & i + n).Font.Bold = True '太字
              Me("Label" & i + n).Tag = ws.Cells(fnd.Row + mm - 1, i + 2) 'セル内容をタグに登録
            End If
          End If
        Next i
      End Sub
      

      ラベルコントロールのTagというプロパティに、セルの内容を入れておきます。あとは、クリックで走るプロシージャにて

      Private Sub LabelClick(ByVal i As Integer)
        If Me("Label" & i).Caption = "" Then Exit Sub 'ラベルが空だったら中止
        If Me("Label" & i).Tag <> "" Then MsgBox Me("Label" & i).Tag 'タグがあったらメッセージボックスで表示
        clndr_date = Me.ComboBox1 & "/" & Me.ComboBox2 & "/" & Me("Label" & i).Caption '日付を生成して変数に格納
        clndr_flg = True 'フラグを立てる
        Unload Me 'カレンダーを閉じる
      End Sub
      

      このように、該当ラベルコントロールのTagの内容をメッセージボックスで表示できます。

  5. Mimi より:

    ありがとうございます。残念ながらまだ休日表示ができていません。フォーム1のUIを変更したのが原因なのかと思い、1から組み直してみたりしていますが実装にいたっておりません。

  6. 伊藤 穣 より:

    素晴らしいコードの提供ありがとうございます。とても使いやすいです。
    dtpickerがなくなり途方に暮れておりました。

    • *you より:

      伊藤さん、コメントありがとうございます。お役に立ててとっても嬉しいです!


コメントを残す

メールアドレスが公開されることはありません。 * が付いている欄は必須項目です

このサイトはスパムを低減するために Akismet を使っています。コメントデータの処理方法の詳細はこちらをご覧ください

コメントは承認制ですので、反映までしばらくお待ち下さい。(稀にスパムの誤判定にて届かないこともあるようですので、必要な際はお問い合わせからお願い致します。)