【VBA】セルクリックでカレンダー入力（ユーザーフォーム）を作る

スポンサーリンク
excelvba エクセル
2021.02.10
スポンサーリンク

エクセルでカレンダー入力をしようと思うとアドインを入れたり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 (30326 ダウンロード )

以下はソースです。

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」に関しては関係ないセルでも実行します。

ある程度の負荷が出ることを考慮して作成しましょう。

スポンサーリンク

コメント

タイトルとURLをコピーしました