エクセルでカレンダー入力をしようと思うとアドインを入れたりACCESSのカレンダーコントロールを使ったりする方法がありますがカスタムには向いていません。
また、セルをクリックしてそのセルに日付を入れたいという希望もあります。
なので、ユーザーフォームでカレンダーを作ってみました。
Worksheet_SelectionChange()と合わせてセルがクリックされたら表示するようにしてみましょう。
※Worksheet_SelectionChange()はApplication.EnableEvents = Falseでイベントを抑止することによってWorksheet_SelectionChange()がWorksheet_SelectionChange()を呼ぶということが無いようにしておきましょう。また、範囲が広い場合は重くなる可能性がありますのでご了承ください。
sheetモジュール
まずはセルをクリックしたときの動きを作ります。
sheet名は気にしない前提で、対象のセルを指定します。(Microsoft Excel Objects内のsheet1などに記述します。)
B2セルを入力欄とします。
Private Sub Worksheet_SelectionChange(ByVal Target As Range) 'クリックがあった時の処理 HT_setFile = ActiveSheet.Name 'データファイル名 Application.ScreenUpdating = False '画面描画を抑止 '作成日カレンダー呼び出し 作成日■■■■■■■■■■■■ '対象のセル座標 HT_str_row = 2 '変更箇所 HT_str_col = 2 '変更箇所 If Not Intersect(Target, ThisWorkbook.Worksheets(HT_setFile).Cells(HT_str_row, HT_str_col)) Is Nothing Then Call showcaslender(Target.Value, Target.Row, Target.Column) End If Application.ScreenUpdating = True '画面描画を開始 End Sub
「If Not Intersect(Target, ThisWorkbook.Worksheets(HT_setFile).Cells(HT_str_row, HT_str_col)) Is Nothing Then」がクリックされた場合に反応します。
rangeで範囲指定も可能です。
この「Worksheet_SelectionChange」はセルの選択が変わった時に実行されます。
選択されたセルが条件に合うかで処理をするというものです。
難点はすでに選択されている場合は他のセルを選択しないとセル上をクリックしても反応しない点と処理数が多くなるので重くなるという点です。
後ほど作る標準フォームで選択をし直すなどの処理が必要になることもあります。
ボタン化するなどの方が仕様として優れている場合がありますので臨機応変に修正してください。
標準モジュール
標準モジュールには共通変数(Public )や変数、セルがクリックされた後の処理から、カレンダーフォームを呼び出す処理とそのあとの処理を書いていきます。
'---カレンダー用変数 Public HT_calendar_date As Variant '日付共通変数 Public HT_calendar_flg As Variant '戻り値確認共通変数 Dim post_calendar_date As Variant '受け渡し用日付変数 Dim address_row As Variant 'クリックした行番号 Dim address_col As Variant 'クリックした列番号 Sub showcaslender(ByVal post_calendar_date As Variant, ByVal address_row As Variant, ByVal address_col As Variant) 'カレンダーを開く HT_setFile = ActiveSheet.Name '現在のシート名 Application.ScreenUpdating = False '画面描画を停止 calendar_flg = False 'フラグリセット If IsDate(post_calendar_date) = False Then '日付が入ってなければ今日の日付 HT_calendar_date = Date '今日の日付を格納 Else HT_calendar_date = post_calendar_date 'テキストボックスの日付を格納 End If calender_form.Show 'カレンダーを開く '戻りが有ったら最初のセルにセット If HT_calendar_flg = True Then ThisWorkbook.Worksheets(HT_setFile).Cells(address_row, address_col).Value = Format(HT_calendar_date, "yyyy/mm/dd") 'クリックされた日付を上書き End If Application.ScreenUpdating = True '画面描画を開始 End Sub
ここでの問題はPublic変数を使う点です。
フォームへの変数を引き渡しの際は.showでの受け渡しができません。
どうしてもPublic変数が必要になります。重複など変数名の設定には気をつけましょう。
ユーザーフォーム
ユーザーフォームに関してはビジュアル部分があるのでファイルを掲載します。
プロジェクトからインポートしてください。
フォームの見た目はこんな感じです。
フォームソースのダウンロードはこちら
calender_form.zip (29817 ダウンロード )以下はソースです。
Private Sub UserForm_Initialize() 'Form開始時 Dim i As Integer For i = -1 To 1 '年の前後設定※変更可能箇所 Me.year_select.AddItem CStr((Year(HT_calendar_date)) + i) Next i For i = 1 To 12 '月登録 Me.month_select.AddItem CStr(i) Next i Me.year_select = Year(HT_calendar_date) '年を指定 Me.month_select = Month(HT_calendar_date) '月を指定 End Sub Private Sub calendar_set() 'カレンダーの作成と表示 Dim yy As Integer Dim mm As Integer Dim i As Integer Dim n As Integer Dim endday As Integer '年か月どちらか入ってなければ中止 If Me.year_select = "" Or Me.month_select = "" Then Exit Sub End If yy = Me.year_select '年セット mm = Me.month_select '月セット For i = 1 To 37 '日ラベルの初期化 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) = HT_calendar_date Then Me("Label" & i + n).BackColor = RGB(200, 200, 200) 'TextBoxの日と同じなら色をつける End If Next i End Sub Private Sub LabelClick(ByVal label_num As Integer) '日付がクリックされたら戻る If Me("Label" & label_num).Caption = "" Then Exit Sub 'ラベルが空だったら中止 End If HT_calendar_date = Me.year_select & "/" & Me.month_select & "/" & Me("Label" & label_num).Caption '日付を生成して変数に格納 HT_calendar_flg = True '戻りをセットするためにフラグを立てる Unload Me 'カレンダーを閉じる End Sub Private Sub bebtn_Click() '戻るボタン If Me.month_select = 1 Then '1月だったら12月年戻し Me.year_select = Me.year_select - 1 Me.month_select = 12 Else Me.month_select = Me.month_select - 1 End If End Sub Private Sub afbtn_Click() '進むボタン If Me.month_select = 12 Then '12月だったら1月年進め Me.year_select = Me.year_select + 1 Me.month_select = 1 Else Me.month_select = Me.month_select + 1 End If End Sub Private Sub year_select_Change() '年が変更されたとき Call calendar_set End Sub Private Sub month_select_Change() '月が変更されたとき Call calendar_set End Sub Private Sub Label1_Click(): Call LabelClick(1): End Sub Private Sub Label2_Click(): Call LabelClick(2): End Sub Private Sub Label3_Click(): Call LabelClick(3): End Sub Private Sub Label4_Click(): Call LabelClick(4): End Sub Private Sub Label5_Click(): Call LabelClick(5): End Sub Private Sub Label6_Click(): Call LabelClick(6): End Sub Private Sub Label7_Click(): Call LabelClick(7): End Sub Private Sub Label8_Click(): Call LabelClick(8): End Sub Private Sub Label9_Click(): Call LabelClick(9): End Sub Private Sub Label10_Click(): Call LabelClick(10): End Sub Private Sub Label11_Click(): Call LabelClick(11): End Sub Private Sub Label12_Click(): Call LabelClick(12): End Sub Private Sub Label13_Click(): Call LabelClick(13): End Sub Private Sub Label14_Click(): Call LabelClick(14): End Sub Private Sub Label15_Click(): Call LabelClick(15): End Sub Private Sub Label16_Click(): Call LabelClick(16): End Sub Private Sub Label17_Click(): Call LabelClick(17): End Sub Private Sub Label18_Click(): Call LabelClick(18): End Sub Private Sub Label19_Click(): Call LabelClick(19): End Sub Private Sub Label20_Click(): Call LabelClick(20): End Sub Private Sub Label21_Click(): Call LabelClick(21): End Sub Private Sub Label22_Click(): Call LabelClick(22): End Sub Private Sub Label23_Click(): Call LabelClick(23): End Sub Private Sub Label24_Click(): Call LabelClick(24): End Sub Private Sub Label25_Click(): Call LabelClick(25): End Sub Private Sub Label26_Click(): Call LabelClick(26): End Sub Private Sub Label27_Click(): Call LabelClick(27): End Sub Private Sub Label28_Click(): Call LabelClick(28): End Sub Private Sub Label29_Click(): Call LabelClick(29): End Sub Private Sub Label30_Click(): Call LabelClick(30): End Sub Private Sub Label31_Click(): Call LabelClick(31): End Sub Private Sub Label32_Click(): Call LabelClick(32): End Sub Private Sub Label33_Click(): Call LabelClick(33): End Sub Private Sub Label34_Click(): Call LabelClick(34): End Sub Private Sub Label35_Click(): Call LabelClick(35): End Sub Private Sub Label36_Click(): Call LabelClick(36): End Sub Private Sub Label37_Click(): Call LabelClick(37): End Sub
色々入っていますがフォームをインポートしてもらってから見ていった方がいいかもしれません。
上記を実装するとセルをクリックするとカレンダーが表示して選択したセルにカレンダーで選んだ日付が入ります。
細かい設定は変える必要があるかもしれませんがとりあえず実行出来るかなと思います。
尚、セルが選択されたら実行する「Worksheet_SelectionChange」に関しては関係ないセルでも実行します。
ある程度の負荷が出ることを考慮して作成しましょう。
コメント