カレンダーフォームをクリックして日付入力

Excelの日付入力をカレンダーフォームの日付クリックで入力したい。
昔（調べてみると2007までは、標準であったようです。)は出来ていたようなのですが、
最近は出来なくなったようで、excel calendar form とかで検索するとヒントやダウンロードできるものが
たくさん見つかりました。

Access2007(Access2007runtime)が前提で優しく解説されているものが見つかりますが、runtimeのダウンロードすらできません。
Access2007があれば、こんな感じになります。

セルの書式設定(yyyy/mm/dd (aaa))でカレンダー表示判定し、そのセルの直下にカレンダーを表示する。
セルの日付をカレンダー表示の初期値にする。

Worksheet_SelectionChange

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    If Range(Target.Address).NumberFormatLocal = "yyyy/mm/dd (aaa)" Then
        ActiveSheet.Calendar1.Top = Target.Offset(1, 0).Top
        ActiveSheet.Calendar1.Left = Target.Offset(1, 0).Left
        If IsDate(Range(Target.Address)(1).Value) Then
            ActiveSheet.Calendar1.Year = Year(Range(Target.Address)(1).Value)
            ActiveSheet.Calendar1.Month = Month(Range(Target.Address)(1).Value)
            ActiveSheet.Calendar1.Day = Day(Range(Target.Address)(1).Value)
        Else
            ActiveSheet.Calendar1.Year = Year(Now)
            ActiveSheet.Calendar1.Month = Month(Now)
            ActiveSheet.Calendar1.Day = Day(Now)
        End If
        ActiveSheet.Calendar1.Visible = True            ' カレンダーフォームを起動する
    Else
        ActiveSheet.Calendar1.Visible = False
    End If
End Sub

Private Sub Calendar1_Click()
    Selection.Value = Calendar1.Value
    ActiveSheet.Calendar1.Visible = False
End Sub

カレンダーフォーム作成

カレンダーフォーム作成では大変お世話になりました。
老眼にはキツイ作業でした。

カレンダーフォームをマクロで作成する

老眼でも頑張れるかもと思わせるのもです。
発想的には
１．フォームはマクロで作成
２．使い終わったらマクロで消す
３．最小限のマクロで動作する

祝祭日判定なしですが、フォーム生成から消去までやっているので、フォームが残ったりはしません。
消去は多少強引ですが。。。

使うにには、設定変更が必要です。

フォームは完全自動生成

作ってみて

やってみて思うのは、フォームは自動生成するものでは無いな！
ただし、フォームの作成が、マクロから出来ると、老眼には優しい
たくさんのページを参考にして、動作するものが出来たので、メモ的に残します。

1.sheetマクロ
こうすると、カレンダ表示が書式で制御できて、EXCEL側の入力ミスも減る？
セルの書式を判定して、カレンダーフォームを起動しています。

Worksheet_SelectionChange

Private Sub Worksheet_SelectionChange(ByVal target As Range)
    If Range(target.Address).NumberFormatLocal = "yyyy/mm/dd (aaa)" Then
        Call CalendarModule.open_calendar(target)           ' カレンダーフォームを起動する
        Exit Sub
    End If
End Sub

2.クラスモジュール
ControlSetting　として　保存
イベント発生と処理を標準モジュールで記述したかったのですが、
　その方法が見つからず、断念しました。
　カレンダーフォームで作成した、ラベルやボタンでイベントが発生すると、ここが呼ばれます。

ControlSetting

Option Explicit

Public WithEvents Label As MSForms.Label                        ' ラベル
Public WithEvents ComboBox As MSForms.ComboBox                        ' 日付ラベル

Public Sub LabelNewClass(ByVal objLabel As MSForms.Label)
    Set Label = objLabel
End Sub

Public Sub ComboBoxNewClass(ByVal objComboBox As MSForms.ComboBox)
    Set ComboBox = objComboBox
End Sub

Private Sub Label_Click()
    Select Case True
        Case Label.Name = "LBL_PREV"
            Call LblMonthClick(-1)  '前月
        Case Label.Name = "LBL_NEXT"
            Call LblMonthClick(1)   '翌月
        Case Label.Name = "LBL_YM"
            Call LblYMClick
        Case Label.Name Like "LBL_DD*"
            Call LblDDClick(Mid(Me.Label.Name, 7))
    End Select
End Sub

Private Sub ComboBox_Change()
    If ComboBox.Text = "" Then Exit Sub
    If Not (Me.ComboBox.Visible) Then Exit Sub
    Select Case ComboBox.Name
        Case "CBO_YEAR", "CBO_MONTH"
            Call CobYMChange
    End Select
End Sub

３.標準モジュール
　フォームの作成、カレンダーの更新、いろりろやってます。

CalendarModule

Option Explicit

Private Const cnsSyear = 1900               '対応年　はじめ
Private Const cnsEyear = 2100               '対応年　終わり

' フォーム上の色指定等の定数
Private Const cnsBC_Select = &HFFCC33       ' 選択日付の背景色
Private Const cnsBC_Other = &HE0E0E0        ' 当月以外の背景色
Private Const cnsBC_Sunday = &HFFDDFF       ' 日曜の背景色
Private Const cnsBC_Saturday = &HDDFFDD     ' 土曜の背景色
Private Const cnsBC_Month = &HFFFFFF        ' 当月土日以外の背景色
Private Const cnsFC_Normal = &HC00000       ' 文字色

Public LBL_PREV As MSForms.Label            ' ←
Public LBL_NEXT As MSForms.Label            ' →
Public LBL_YM   As MSForms.Label            ' 年月
Public CBO_YEAR As MSForms.ComboBox         ' 年
Public CBO_MONTH As MSForms.ComboBox        ' 月
Public LBL_DD(1 To 42) As MSForms.Label     ' 日
Public days(1 To 42) As Date

Public newFormName As String                ' formName
Public myForm                               ' As UserForm1
Public nowCalendarDate As Date              ' 現在表示カレンダー日付　常に月初
Public CalendarFormNo As Integer            ' UserForm 名称変更後同じ名前を使うとERRになる

Public reTarget As Range

'form生成
Sub open_calendar(target As Range)
'    Debug.Print "open_calendar:" & newFormName
    Set reTarget = target                   ' 呼び元

    '*************
    'イベント
    '←　yyyy年mm月 →
    Dim oLBL_PREV As Object
    Dim oLBL_NEXT As Object
    Dim oLBL_YM As Object
    Set oLBL_PREV = New ControlSetting
    Set oLBL_NEXT = New ControlSetting
    Set oLBL_YM = New ControlSetting

    'yyyy mm
    Dim oCBO_YEAR As Object
    Dim oCBO_MONTH As Object
    Set oCBO_YEAR = New ControlSetting
    Set oCBO_MONTH = New ControlSetting

    'dd
    Dim oLBL_DD(1 To 42) As Object

    Dim vbcomp
    Dim eform

    'カレンダーフォーム作成
    eform = False
    If Not (newFormName = "") Then
        With ThisWorkbook.VBProject
            For Each vbcomp In .VBComponents
                If vbcomp.Name = newFormName And vbcomp.Type = 3 Then
                    eform = True
                    Exit For
                End If
            Next
        End With
    End If
    If Not (eform) Then newFormName = MSFormAdd()
    Set myForm = UserForms.Add(newFormName)

    'セルデータ取得
    Dim myDate As Date
    If (IsDate(target.Value)) Then
        myDate = CDate(target.Value)
    Else
        myDate = Date
    End If

    With myForm
        '← 年 月 →
        Set LBL_PREV = .Controls.Add("Forms.Label.1", "LBL_PREV", True)
        With LBL_PREV
            .BackColor = &H99CCCC
            .BorderColor = &H808080
            .ForeColor = &H808080
            .Height = 11.25
            .Width = 14.75     '16.75
            .Left = 1          '3
            .Top = 1
            .Font.Size = 11
            .Caption = "←"
            .TextAlign = fmTextAlignCenter
'            Debug.Print .Name
        End With
        Call oLBL_PREV.LabelNewClass(LBL_PREV)

        Set LBL_NEXT = .Controls.Add("Forms.Label.1", "LBL_NEXT", True)
        With LBL_NEXT
            .BackColor = &H99CCCC
            .BorderColor = &H808080
            .ForeColor = &H808080
            .Height = 11.25
            .Width = 14.75     '17
            .Left = 103.5      '108
            .Top = 1
            .Font.Size = 11
            .Caption = "→"
            .TextAlign = fmTextAlignCenter
        End With
        Call oLBL_NEXT.LabelNewClass(LBL_NEXT)

        Set CBO_YEAR = .Controls.Add("Forms.ComboBox.1", "CBO_YEAR", True)
        With CBO_YEAR
            .BackColor = &H80000005
            .BorderColor = &H80000006
            .Height = 13
            .Width = 38
            .Left = 29          '31
            .Top = 0
            .Font.Size = 8
            .TextAlign = fmTextAlignLeft
            .TextColumn = -1
            .IMEMode = fmIMEModeDisable
            .ListWidth = 38
            .Text = Year(myDate)
        End With
        Call oCBO_YEAR.ComboBoxNewClass(CBO_YEAR)

        Set CBO_MONTH = .Controls.Add("Forms.ComboBox.1", "CBO_MONTH", True)
        With CBO_MONTH
            .BackColor = &H80000005
            .BorderColor = &H80000006
            .Height = 13
            .Width = 32
            .Left = 66          '68
            .Top = 0
            .Font.Size = 8
            .TextAlign = fmTextAlignLeft
            .TextColumn = -1
            .IMEMode = fmIMEModeDisable
            .ListWidth = 30
            .Text = Format(Month(myDate), "00")
        End With
        Call oCBO_MONTH.ComboBoxNewClass(CBO_MONTH)

        Set LBL_YM = .Controls.Add("Forms.Label.1", "LBL_YM", True)
        With LBL_YM
            .BackColor = &HFFCCCC
            .BorderColor = &HC0C0&
            .ForeColor = &H800080
            .Height = 11.25
            .Width = 86.5
            .Left = 16.5    '20.5
            .Top = 1
            .Font.Size = 11
            .Caption = ""
            .TextAlign = fmTextAlignCenter
        End With
        Call oLBL_YM.LabelNewClass(LBL_YM)

        '日月火水木金土
        Dim weekLabel(0 To 6) As Object
        Dim weekdays As String
        weekdays = "日月火水木金土"
        Dim weekdaysi As Integer
        For weekdaysi = 0 To 6
            Set weekLabel(weekdaysi) = .Controls.Add("Forms.Label.1", "weekLabel" & weekdaysi)
            With weekLabel(weekdaysi)
                .Height = 10
                .Width = 16.75
                .Left = 1 + weekdaysi * 17
                .Top = 13
                .Font.Size = 9
                .ForeColor = cnsFC_Normal
                .TextAlign = fmTextAlignCenter
                .Caption = Mid(weekdays, weekdaysi + 1, 1)
                Select Case weekdaysi
                    Case 0
                        .BackColor = cnsBC_Sunday
                    Case 6
                        .BackColor = cnsBC_Saturday
                    Case Else
                        .BackColor = cnsBC_Month
                End Select
            End With
        Next weekdaysi

        '7日×6週
        Dim dayi As Integer
        For dayi = 1 To 42
             Set oLBL_DD(dayi) = New ControlSetting
             Set LBL_DD(dayi) = .Controls.Add("Forms.Label.1", "LBL_DD" & dayi, True)
             With LBL_DD(dayi)
                 .Height = 10
                 .Width = 16.75
                 .Top = 24 + ((dayi - 1) \ 7) * 10.25
                 .Left = 1 + ((dayi - 1) Mod 7) * 17
                 .TextAlign = fmTextAlignCenter
                 .Caption = dayi
            End With
            Call oLBL_DD(dayi).LabelNewClass(LBL_DD(dayi))
        Next dayi

        Call calendarSet(myDate) 'カレンダー作成
        .Show
    End With
End Sub

'カレンダー作成
Private Sub calendarSet(myDate As Date)
    Dim wDate As Date
    Dim dayi As Integer
    Dim weekNo As Integer
    Dim endDay As Integer

    With myForm
        For dayi = 1 To 42 'ラベルの初期化
            .Controls("LBL_DD" & dayi).Caption = ""
            .Controls("LBL_DD" & dayi).BackColor = cnsBC_Other
        Next

        nowCalendarDate = CDate(Year(myDate) & "/" & Month(myDate) & "/" & 1)  '当月1日
        endDay = day(DateAdd("d", -1, DateAdd("m", 1, nowCalendarDate)))       '月末日の算出
        weekNo = Weekday(nowCalendarDate) - 1                                  '当月1日の曜日番号に、マイナス1したもの

        '前月
        For dayi = 1 To weekNo
            With .Controls("LBL_DD" & weekNo - dayi + 1)
                .Caption = day(nowCalendarDate - dayi)   '日を入れる
                .BackColor = cnsBC_Other
            End With
            days(weekNo - dayi + 1) = nowCalendarDate - dayi
        Next

        '当月
        For dayi = 1 To endDay
            With .Controls("LBL_DD" & dayi + weekNo)
                .Caption = dayi '日を入れる
                wDate = CDate(Year(myDate) & "/" & Month(myDate) & "/" & dayi)
                Select Case Weekday(wDate) - 1
                    Case 0
                        .BackColor = cnsBC_Sunday
                    Case 6
                        .BackColor = cnsBC_Saturday
                    Case Else
                        .BackColor = cnsBC_Month
                End Select

                'TextBoxの日と同じなら色をつける
                If wDate = myDate Then .BackColor = cnsBC_Select
            End With
            days(dayi + weekNo) = wDate
        Next dayi

        '翌月
        wDate = DateAdd("m", 1, nowCalendarDate)
        For dayi = endDay + weekNo + 1 To 42
            With .Controls("LBL_DD" & dayi)
                .Caption = dayi - (endDay + weekNo)    '日を入れる
                .BackColor = cnsBC_Other
            End With
            days(dayi) = wDate + (dayi - (endDay + weekNo)) - 1
        Next

        LBL_YM.Caption = Year(nowCalendarDate) & "年" & Format(Month(nowCalendarDate), "00") & "月"
        Call LBL_YEAR_re(Year(nowCalendarDate))
        Call LBL_MONTH_re(Month(nowCalendarDate))

        LBL_YM.Visible = True         '年月ラベル表示
        GpYearMonth False             '年、月コンボボックスは非表示

    End With
End Sub

'***************
'ユーザフォーム追加
Function MSFormAdd()
    Dim newForm As VBIDE.VBComponent
    Dim wk
    For Each wk In ThisWorkbook.VBProject.VBComponents
        If wk.Name Like "CalenderForm*" Then
'           Debug.Print wk.Name
           newFormName = wk.Name
           MSFormRemove
        End If
    Next
    Set newForm = ThisWorkbook.VBProject.VBComponents.Add(vbext_ct_MSForm)
    With newForm
        .Properties("Height") = 106
        .Properties("Width") = 123
        .Properties("Caption") = "日付選択"
        On Error Resume Next
            Do
                CalendarFormNo = CalendarFormNo + 1
                .Properties("name") = "CalenderForm" & CalendarFormNo
                If Err.Number <> 0 Then
                    Debug.Print Err.Description
                    Err.Clear
                Else
                    Exit Do
                End If
            Loop
        On Error GoTo 0
        MSFormAdd = .Properties("name")
    End With
End Function
'ユーザフォーム削除
Sub MSFormRemove()
    Dim vbcomp
    If Not (newFormName = "") Then
        With ThisWorkbook.VBProject
            For Each vbcomp In .VBComponents
                If vbcomp.Name = newFormName And vbcomp.Type = 3 Then
'                    Debug.Print "userform remove is " & newFormName
                    .VBComponents.Remove .VBComponents(newFormName)
                    Exit For
                End If
            Next
        End With
    End If
End Sub

'***************
'←(前月)→(翌月
Public Sub LblMonthClick(wmonth As Integer)
    Call calendarSet(DateAdd("m", wmonth, nowCalendarDate))
    Call LBL_YEAR_re(Year(nowCalendarDate))
    Call LBL_MONTH_re(Month(nowCalendarDate))
    LBL_YM.Visible = True
End Sub

'年
Private Sub LBL_YEAR_re(pYear As Integer)
    Dim intYear As Integer
    With CBO_YEAR
        .Clear
        For intYear = cnsSyear To cnsEyear
            .AddItem CStr(intYear)
        Next
        .Visible = False
        .ListIndex = pYear - cnsSyear
    End With
End Sub

'月
Private Sub LBL_MONTH_re(pMonth As Integer)
    Dim intMonth As Integer
    With CBO_MONTH
        .Clear
        For intMonth = 1 To 12
            .AddItem Format(intMonth, "00")
        Next intMonth
        .Visible = False
        .ListIndex = pMonth - 1
    End With
End Sub

'***************
'年コンボの操作イベント
Public Sub CobYMChange()
    Call calendarSet(CDate(CBO_YEAR.Value & "/" & CBO_MONTH.Value & "/1"))
End Sub

'***************
'yyyy年mm月 コンボの非表示化
Public Sub LblYMClick()
    LBL_YM.Visible = False
    GpYearMonth True
End Sub

'***************
'｢年｣｢月｣コンボの表示/非表示化
Private Sub GpYearMonth(visibleSw As Boolean)
    CBO_YEAR.Visible = visibleSw
    CBO_MONTH.Visible = visibleSw
End Sub

'***************
'日付選択
Public Sub LblDDClick(wdd As String)
    reTarget.Value = days(wdd)
    myForm.Hide
    MSFormRemove  '日付選択フォーム削除
End Sub

たくさんの方のページを参考にしました。

参考した全部のページを書きたいのですが、記録してものだけになります。
ありがとうございました。
カレンダーフォーム
https://ateitexe.com/excel-vba-calendar-control/

表示位置
http://www.ne.jp/asahi/excel/inoue/
http://www.asahi-net.or.jp/~ef2o-inue/download/sub09_020_025.html

MS製
https://hamachan.info/vista/calendar.html

UserFormを作成する
http://touch-sp.hatenablog.com/entry/2017/01/12/144526
http://officetanaka.net/excel/vba/vbe/07.htm

特定のユーザーフォームが存在するかのチェック。
https://detail.chiebukuro.yahoo.co.jp/qa/question_detail/q1473461604

Excel VBA ヒント集
https://qiita.com/muramoto_jp/items/4ba28788a6859eabbf99

Access　フォームは開いてるか調べる
http://psp8155.blog13.fc2.com/blog-entry-305.html

Formの表示状態の取得
https://oshiete.goo.ne.jp/qa/4274740.html

開いているすべてのフォームを参照する
https://www.moug.net/tech/acvba/0100037.html

UserFormを変数で操作する
http://officetanaka.net/excel/vba/tips/tips103.htm

[ExcelVBA] UserForm上で複数コントロールを動的に追加&イベント検出する
https://ateitexe.com/excel-vba-add-userform-control/

ユーザーフォームに動的にボタン等を追加する
https://www.excellovers.com/entry/2017/07/30/155613

UserForm上で複数コントロールを動的に追加&イベント検出する
https://ateitexe.com/excel-vba-add-userform-control/

VBEのモジュールを参照する（VBComponents コレクション）
https://excelwork.info/excel/vbcomponents/

ユーザフォームをコードから作成する
https://www.moug.net/tech/exvba/0090027.html

VBA：コードの自動生成
ボタンのクリックイベントプロシージャを作成
http://blog.livedoor.jp/yorinaga/archives/51924953.html

モジュール内のコードを操作する（CodeModule のメソッド）
https://excelwork.info/excel/codemodulemethod/

物忘れ防止 calendar_v1.xlsm
https://github.com/sugita0301/douzo

UserFormをマクロで作成する

UserFormをマクロで作成してみました。
UserFormをパラメータ（表示位置、サイズ、カラー）指定をマクロで行える点は（老眼だからか）使える！と感じました。
しかし、イベント登録のやり方がわからない、いろいろ設定が必要だったりして、実用的では無いと判断した。

「マクロでフォームを作って保存」メモ

formCreate

'form生成
Sub formCreate(formName As String)
    Dim LBL_PREV As Control
    Dim LBL_NEXT As Control
    Dim CBO_YEAR As Control
    Dim CBO_MONTH As Control
    Dim LBL_YM As Control
    Dim weekLabel(0 To 6) As Control
    Dim LBL_DD(1 To 42) As Control

    Dim newForm As VBIDE.VBComponent
    Set newForm = ThisWorkbook.VBProject.VBComponents.Add(vbext_ct_MSForm)
    With newForm
        .Properties("Height") = 106
        .Properties("Width") = 123
        .Properties("Caption") = "日付選択"
        '.Properties("Name") = formName       'コメントにすると　UserForm〇〇　になる

        '← 年 月 →
        Set LBL_PREV = .Designer.Controls.Add("Forms.Label.1", "LBL_PREV", True)
        With LBL_PREV
            .BackColor = &H99CCCC
            .BorderColor = &H808080
            .ForeColor = &H808080
            .Height = 11.25
            .Width = 14.75     '16.75
            .Left = 1          '3
            .Top = 1
            .Font.Size = 11
            .Caption = "←"
            .TextAlign = fmTextAlignCenter
        End With

        Set LBL_NEXT = .Designer.Controls.Add("Forms.Label.1", "LBL_NEXT", True)
        With LBL_NEXT
            .BackColor = &H99CCCC
            .BorderColor = &H808080
            .ForeColor = &H808080
            .Height = 11.25
            .Width = 14.75     '17
            .Left = 103.5      '108
            .Top = 1
            .Font.Size = 11
            .Caption = "→"
            .TextAlign = fmTextAlignCenter
        End With

        Set CBO_YEAR = .Designer.Controls.Add("Forms.ComboBox.1", "CBO_YEAR", True)
        With CBO_YEAR
            .BackColor = &H80000005
            .BorderColor = &H80000006
            .Height = 12
            .Width = 38
            .Left = 29          '31
            .Top = 1
            .Font.Size = 8
            .TextAlign = fmTextAlignLeft
            .TextColumn = -1
            .IMEMode = fmIMEModeDisable
            .ListWidth = 38
            .Text = Year(myDate)
        End With

        Set CBO_MONTH = .Designer.Controls.Add("Forms.ComboBox.1", "CBO_MONTH", True)
        With CBO_MONTH
            .BackColor = &H80000005
            .BorderColor = &H80000006
            .Height = 12
            .Width = 32
            .Left = 66          '68
            .Top = 1
            .Font.Size = 8
            .TextAlign = fmTextAlignLeft
            .TextColumn = -1
            .IMEMode = fmIMEModeDisable
            .ListWidth = 30
            .Text = Format(Month(myDate), "00")
        End With

        Set LBL_YM = .Designer.Controls.Add("Forms.Label.1", "LBL_YM", True)
        With LBL_YM
            .BackColor = &HFFCCCC
            .BorderColor = &HC0C0&
            .ForeColor = &H800080
            .Height = 11.25
            .Width = 86.5
            .Left = 16.5    '20.5
            .Top = 1
            .Font.Size = 11
            .Caption = ""
            .TextAlign = fmTextAlignCenter
        End With

        '日月火水木金土
        Dim weekdays As String
        weekdays = "日月火水木金土"
        Dim weekdaysi As Integer
        For weekdaysi = 0 To 6
            Set weekLabel(weekdaysi) = .Designer.Controls.Add("Forms.Label.1", "weekLabel" & weekdaysi)
            With weekLabel(weekdaysi)
                .Height = 10
                .Width = 16.75
                .Left = 1 + weekdaysi * 17
                .Top = 13
                .Font.Size = 9
                .ForeColor = cnsFC_Normal
                .TextAlign = fmTextAlignCenter
                .Caption = Mid(weekdays, weekdaysi + 1, 1)
                Select Case weekdaysi
                    Case 0
                        .BackColor = cnsBC_Sunday
                    Case 6
                        .BackColor = cnsBC_Saturday
                    Case Else
                        .BackColor = cnsBC_Month
                End Select
            End With
        Next weekdaysi

        '7日×6週
        Dim dayi As Integer
        For dayi = 1 To 42
             Set LBL_DD(dayi) = .Designer.Controls.Add("Forms.Label.1", "LBL_DD" & dayi, True)
             With LBL_DD(dayi)
                 .Height = 10
                 .Width = 16.75
                 .Top = 24 + ((dayi - 1) \ 7) * 10.25
                 .Left = 1 + ((dayi - 1) Mod 7) * 17
                 .TextAlign = fmTextAlignCenter
                 .Caption = dayi
            End With
        Next dayi
    End With
End Sub

フォーム名が存在するとエラーになる
.Properties("Name") = formName 'コメントにすると　UserForm〇〇　になる

起動はsheetにこのマクロを置いて、セルをクリック

Worksheet_SelectionChange

Private Sub Worksheet_SelectionChange(ByVal target As Range)
    formCreate ("fromCalendar")              ' カレンダーフォームを起動する
End Sub

物忘れ防止 calendar_v2_UserForm.xlsm
https://github.com/sugita0301/douzo

UserFormを使ってみる

物忘れ防止 calendar_v3_event.xlsm
https://github.com/sugita0301/douzo

1.sheetにはいつもの起動マクロ

'''vba:Worksheet_SelectionChange
Private Sub Worksheet_SelectionChange(ByVal target As Range)
If Range(target.Address).NumberFormatLocal = "yyyy/mm/dd (aaa)" Then
Call CalendarModule.open_calendar(target) ' カレンダーフォームを起動する
Exit Sub
End If
End Sub

2.フォームのマクロ

userform

Option Explicit

Public cmbYMevent As Boolean
Private Const cnsSyear = 1900               '対応年　はじめ
Private Const cnsEyear = 2100               '対応年　終わり

Private Sub UserForm_Initialize()           'Formが開くとき
    Dim i As Integer
    For i = cnsSyear To cnsEyear
        Me.CBO_YEAR.AddItem i
    Next i
    For i = 1 To 12 '月を登録
        Me.CBO_MONTH.AddItem Format(i, "00")
    Next i
    cmbYMevent = True
End Sub

'-- イベント処理
Private Sub LBL_PREV_Click()                '←(前月)
    CalendarModule.LblMonthClick -1
End Sub
Private Sub LBL_NEXT_Click()                '→(翌月)
    CalendarModule.LblMonthClick 1
End Sub
Private Sub LBL_YM_Click()                  'yyyy年mm月
    CalendarModule.LblYMClick
End Sub
Private Sub CBO_YEAR_Change()               '年コンボ
    If cmbYMevent Then CalendarModule.CmbYMChange CDate(CBO_YEAR.Value & "/" & CBO_MONTH.Value & "/1")
End Sub
'月コンボ
Private Sub CBO_MONTH_Change()
    If cmbYMevent Then CalendarModule.CmbYMChange CDate(CBO_YEAR.Value & "/" & CBO_MONTH.Value & "/1")
End Sub
'日
Private Sub LBL_DD1_Click(): Call CalendarModule.LblDDClick(1): End Sub
Private Sub LBL_DD2_Click(): Call CalendarModule.LblDDClick(2): End Sub
Private Sub LBL_DD3_Click(): Call CalendarModule.LblDDClick(3): End Sub
Private Sub LBL_DD4_Click(): Call CalendarModule.LblDDClick(4): End Sub
Private Sub LBL_DD5_Click(): Call CalendarModule.LblDDClick(5): End Sub
Private Sub LBL_DD6_Click(): Call CalendarModule.LblDDClick(6): End Sub
Private Sub LBL_DD7_Click(): Call CalendarModule.LblDDClick(7): End Sub
Private Sub LBL_DD8_Click(): Call CalendarModule.LblDDClick(8): End Sub
Private Sub LBL_DD9_Click(): Call CalendarModule.LblDDClick(9): End Sub
Private Sub LBL_DD10_Click(): Call CalendarModule.LblDDClick(10): End Sub
Private Sub LBL_DD11_Click(): Call CalendarModule.LblDDClick(11): End Sub
Private Sub LBL_DD12_Click(): Call CalendarModule.LblDDClick(12): End Sub
Private Sub LBL_DD13_Click(): Call CalendarModule.LblDDClick(13): End Sub
Private Sub LBL_DD14_Click(): Call CalendarModule.LblDDClick(14): End Sub
Private Sub LBL_DD15_Click(): Call CalendarModule.LblDDClick(15): End Sub
Private Sub LBL_DD16_Click(): Call CalendarModule.LblDDClick(16): End Sub
Private Sub LBL_DD17_Click(): Call CalendarModule.LblDDClick(17): End Sub
Private Sub LBL_DD18_Click(): Call CalendarModule.LblDDClick(18): End Sub
Private Sub LBL_DD19_Click(): Call CalendarModule.LblDDClick(19): End Sub
Private Sub LBL_DD20_Click(): Call CalendarModule.LblDDClick(20): End Sub
Private Sub LBL_DD21_Click(): Call CalendarModule.LblDDClick(21): End Sub
Private Sub LBL_DD22_Click(): Call CalendarModule.LblDDClick(22): End Sub
Private Sub LBL_DD23_Click(): Call CalendarModule.LblDDClick(23): End Sub
Private Sub LBL_DD24_Click(): Call CalendarModule.LblDDClick(24): End Sub
Private Sub LBL_DD25_Click(): Call CalendarModule.LblDDClick(25): End Sub
Private Sub LBL_DD26_Click(): Call CalendarModule.LblDDClick(26): End Sub
Private Sub LBL_DD27_Click(): Call CalendarModule.LblDDClick(27): End Sub
Private Sub LBL_DD28_Click(): Call CalendarModule.LblDDClick(28): End Sub
Private Sub LBL_DD29_Click(): Call CalendarModule.LblDDClick(29): End Sub
Private Sub LBL_DD30_Click(): Call CalendarModule.LblDDClick(30): End Sub
Private Sub LBL_DD31_Click(): Call CalendarModule.LblDDClick(31): End Sub
Private Sub LBL_DD32_Click(): Call CalendarModule.LblDDClick(32): End Sub
Private Sub LBL_DD33_Click(): Call CalendarModule.LblDDClick(33): End Sub
Private Sub LBL_DD34_Click(): Call CalendarModule.LblDDClick(34): End Sub
Private Sub LBL_DD35_Click(): Call CalendarModule.LblDDClick(35): End Sub
Private Sub LBL_DD36_Click(): Call CalendarModule.LblDDClick(36): End Sub
Private Sub LBL_DD37_Click(): Call CalendarModule.LblDDClick(37): End Sub
Private Sub LBL_DD38_Click(): Call CalendarModule.LblDDClick(38): End Sub
Private Sub LBL_DD39_Click(): Call CalendarModule.LblDDClick(39): End Sub
Private Sub LBL_DD40_Click(): Call CalendarModule.LblDDClick(40): End Sub
Private Sub LBL_DD41_Click(): Call CalendarModule.LblDDClick(41): End Sub
Private Sub LBL_DD42_Click(): Call CalendarModule.LblDDClick(42): End Sub

3.標準モジュール

CalendarModule

Option Explicit

' フォーム上の色指定等の定数
Private Const cnsBC_Select = &HFFCC33       ' 選択日付の背景色
Private Const cnsBC_Other = &HE0E0E0        ' 当月以外の背景色
Private Const cnsBC_Sunday = &HFFDDFF       ' 日曜の背景色
Private Const cnsBC_Saturday = &HDDFFDD     ' 土曜の背景色
Private Const cnsBC_Month = &HFFFFFF        ' 当月土日以外の背景色

Private days(1 To 42) As Date
Private nowCalendarDate As Date              ' 現在表示カレンダー日付　常に月初
Private targetDate As Date
Private retarget As Range

'---- form生成
Public Sub open_calendar(target As Range)
    Set retarget = target                   '日クリックの返し先
    If (IsDate(target.Value)) Then          'セルデータ取得
        targetDate = CDate(target.Value)
    Else
        targetDate = Date
    End If
    calendarSet targetDate 'カレンダー作成
    fromCalendar.Show
End Sub

'---- カレンダー作成
Private Sub calendarSet(calendarSetDate As Date)
   Dim wDate As Date
    Dim dayi As Integer
    Dim weekNo As Integer
    Dim endDay As Integer

    With fromCalendar
        For dayi = 1 To 42 'ラベルの初期化
            .Controls("LBL_DD" & dayi).Caption = ""
            .Controls("LBL_DD" & dayi).BackColor = cnsBC_Other
        Next

        nowCalendarDate = CDate(Year(calendarSetDate) & "/" & Month(calendarSetDate) & "/" & 1)  '当月1日
        endDay = day(DateAdd("d", -1, DateAdd("m", 1, nowCalendarDate)))       '月末日の算出
        weekNo = Weekday(nowCalendarDate) - 1                                  '当月1日の曜日番号に、マイナス1したもの

        '前月
        For dayi = 1 To weekNo
            With .Controls("LBL_DD" & weekNo - dayi + 1)
                .Caption = day(nowCalendarDate - dayi)   '日を入れる
                .BackColor = cnsBC_Other
            End With
            days(weekNo - dayi + 1) = nowCalendarDate - dayi
        Next

        '当月
        For dayi = 1 To endDay
            With .Controls("LBL_DD" & dayi + weekNo)
                .Caption = dayi '日を入れる
                wDate = CDate(Year(calendarSetDate) & "/" & Month(calendarSetDate) & "/" & dayi)
                Select Case Weekday(wDate) - 1
                    Case 0
                        .BackColor = cnsBC_Sunday
                    Case 6
                        .BackColor = cnsBC_Saturday
                    Case Else
                        .BackColor = cnsBC_Month
                End Select

                'TextBoxの日と同じなら色をつける
                If wDate = calendarSetDate Then
                .BackColor = cnsBC_Select
                End If
            End With
            days(dayi + weekNo) = wDate
        Next dayi

        '翌月
        wDate = DateAdd("m", 1, nowCalendarDate)
        For dayi = endDay + weekNo + 1 To 42
            With .Controls("LBL_DD" & dayi)
                .Caption = dayi - (endDay + weekNo)    '日を入れる
                .BackColor = cnsBC_Other
            End With
            days(dayi) = wDate + (dayi - (endDay + weekNo)) - 1
        Next

        YM_YEAR_MONTH_re nowCalendarDate               '年月ラベル更新
    End With
End Sub
Private Sub YM_YEAR_MONTH_re(wDate As Date)
    With fromCalendar
        .cmbYMevent = False
        .LBL_YM.Caption = Year(wDate) & "年" & Format(Month(wDate), "00") & "月"
        .CBO_YEAR = Year(wDate) '年を指定
        .CBO_MONTH = Month(wDate) '月を指定
        .LBL_YM.Visible = True
        .cmbYMevent = True
    End With
End Sub

'-- イベント処理
Public Sub LblMonthClick(wmonth As Integer)             '←(前月)→(翌月
    calendarSet DateAdd("m", wmonth, nowCalendarDate)
End Sub
Public Sub LblYMClick()                                 'yyyy年mm月
    fromCalendar.LBL_YM.Visible = False
End Sub
Public Sub CmbYMChange(wDate As Date)                   'yyyy年mm月 コンボ
    calendarSet wDate
End Sub
Public Sub LblDDClick(i As Integer)                     '日選択
    retarget.Value = days(i)
    fromCalendar.Hide
End Sub

クラスモジュール化

日付選択イベント処理をクラスモジュール化してみます。

1.sheetにはいつもの起動マクロ

変更がないので省略

2.フォームのマクロです。

日クリックイベントをクラスへ移動しました。
変更行は末尾に'class がある行です。
日ラベルのイベント処理は削除しました
```vba:userform
Option Explicit

Public cmbYMevent As Boolean
Private Const cnsSyear = 1900 '対応年　はじめ
Private Const cnsEyear = 2100 '対応年　終わり

Private cDateLabel(1 To 42) As New Class1 '日付ラベルイベント 'class

Private Sub UserForm_Initialize() 'Formが開くとき
Dim i As Integer
For i = cnsSyear To cnsEyear
Me.CBO_YEAR.AddItem i
Next i
For i = 1 To 12 '月を登録
Me.CBO_MONTH.AddItem Format(i, "00")
Next i
cmbYMevent = True

' 各日付ラベルイベントクラスの初期化                            'class
For i = 1 To 42                                                 'class
Debug.Print "LBL_DD" & i                                        'class
    Call cDateLabel(i).NewClass(Me.Controls("LBL_DD" & i), i)   'class
Next                                                            'class

End Sub

'-- イベント処理
Private Sub LBL_PREV_Click() '←(前月)
CalendarModule.LblMonthClick -1
End Sub
Private Sub LBL_NEXT_Click() '→(翌月)
CalendarModule.LblMonthClick 1
End Sub
Private Sub LBL_YM_Click() 'yyyy年mm月
CalendarModule.LblYMClick
End Sub
Private Sub CBO_YEAR_Change() '年コンボ
If cmbYMevent Then CalendarModule.CmbYMChange CDate(CBO_YEAR.Value & "/" & CBO_MONTH.Value & "/1")
End Sub
'月コンボ
Private Sub CBO_MONTH_Change()
If cmbYMevent Then CalendarModule.CmbYMChange CDate(CBO_YEAR.Value & "/" & CBO_MONTH.Value & "/1")
End Sub
```

3.標準モジュール　

CalendarModule です。変更ありません。

4.今回追加したクラスモジュール

Class1

Option Explicit
Public WithEvents Label As MSForms.Label    ' 日ラベル
Private g_lngIndex As Integer               ' 日ラベルを配列に
'----------
'引数：Arg1 = ラベル(Object)
'　　　Arg2 = 位置INDEX(Long)
Public Sub NewClass(ByVal objLabel As MSForms.Label, ByVal lngIx As Integer)
    Set Label = objLabel
    g_lngIndex = lngIx
End Sub

'----------
'ラベルのクリックイベント
Private Sub Label_Click()
    Call CalendarModule.LblDDClick(g_lngIndex)
End Sub

選択したセルの下にカレンダー表示

今のままだと、カレンダーが画面の中央に表示なので選択したセルの下に表示をします。
これが結構厄介なようで、
こちら http://www.asahi-net.or.jp/~ef2o-inue/download/sub09_020_025.htmlのパクリです。

出来上がりは、今までと見た目かわりません。
選択セル直下にカレンダー表示

オプション機能なのか、画面からはみ出す場合は、選択したセルの直上に表示されます。すごい！!

フォームの表示位置調整は、こちらhttp://www.asahi-net.or.jp/~ef2o-inue/download/sub09_020_025.htmlのパクリです。
なので、ダウンロードして、modCalendar5Rだけが必要だったので、標準モジュールに配置しています。

1.sheetマクロは変更なし

2.フォームマクロも変更なし

3.標準モジュールのCalendarModule

　表示位置設定が追加になっています。
```vba:CalendarModule
Option Explicit

' フォーム上の色指定等の定数
Private Const cnsBC_Select = &HFFCC33 ' 選択日付の背景色
Private Const cnsBC_Other = &HE0E0E0 ' 当月以外の背景色
Private Const cnsBC_Sunday = &HFFDDFF ' 日曜の背景色
Private Const cnsBC_Saturday = &HDDFFDD ' 土曜の背景色
Private Const cnsBC_Month = &HFFFFFF ' 当月土日以外の背景色

Private days(1 To 42) As Date
Private nowCalendarDate As Date ' 現在表示カレンダー日付　常に月初
Private targetDate As Date
Private retarget As Range

'---- form生成
Public Sub open_calendar(target As Range)
Set retarget = target '日クリックの返し先
If (IsDate(target.Value)) Then 'セルデータ取得
targetDate = CDate(target.Value)
Else
targetDate = Date
End If
calendarSet targetDate 'カレンダー作成

'----ユーザーフォーム表示位置--------------------------------------------------------------------
Dim lngLeft As Long                                             ' 横位置
Dim lngTop As Long                                              ' 縦位置
With fromCalendar
     Call modCalendar5R.FP_GetFormPosition(target, .Width, .Height, lngLeft, lngTop) ' ユーザーフォーム表示位置取得
    ' フォーム表示位置の確認
    If ((lngLeft <> 0) Or (lngTop <> 0)) Then
        ' 指定がある場合はマニュアル指定
        .StartUpPosition = 0
        .Left = lngLeft
        .Top = lngTop
    Else
        ' 指定がない場合はスクリーンの中央
        .StartUpPosition = 2
    End If
End With
'-----------------------------------------------------------------------------------------------

fromCalendar.Show

End Sub

'---- カレンダー作成
Private Sub calendarSet(calendarSetDate As Date)
Dim wDate As Date
Dim dayi As Integer
Dim weekNo As Integer
Dim endDay As Integer

With fromCalendar
    For dayi = 1 To 42 'ラベルの初期化
        .Controls("LBL_DD" & dayi).Caption = ""
        .Controls("LBL_DD" & dayi).BackColor = cnsBC_Other
    Next

    nowCalendarDate = CDate(Year(calendarSetDate) & "/" & Month(calendarSetDate) & "/" & 1)  '当月1日
    endDay = day(DateAdd("d", -1, DateAdd("m", 1, nowCalendarDate)))       '月末日の算出
    weekNo = Weekday(nowCalendarDate) - 1                                  '当月1日の曜日番号に、マイナス1したもの

    '前月
    For dayi = 1 To weekNo
        With .Controls("LBL_DD" & weekNo - dayi + 1)
            .Caption = day(nowCalendarDate - dayi)   '日を入れる
            .BackColor = cnsBC_Other
        End With
        days(weekNo - dayi + 1) = nowCalendarDate - dayi
    Next

    '当月
    For dayi = 1 To endDay
        With .Controls("LBL_DD" & dayi + weekNo)
            .Caption = dayi                         '日を入れる
            wDate = CDate(Year(calendarSetDate) & "/" & Month(calendarSetDate) & "/" & dayi)
            Select Case Weekday(wDate) - 1
                Case 0
                    .BackColor = cnsBC_Sunday
                Case 6
                    .BackColor = cnsBC_Saturday
                Case Else
                    .BackColor = cnsBC_Month
            End Select

            'TextBoxの日と同じなら色をつける
            If wDate = calendarSetDate Then
            .BackColor = cnsBC_Select
            End If
        End With
        days(dayi + weekNo) = wDate
    Next dayi

    '翌月
    wDate = DateAdd("m", 1, nowCalendarDate)
    For dayi = endDay + weekNo + 1 To 42
        With .Controls("LBL_DD" & dayi)
            .Caption = dayi - (endDay + weekNo)    '日を入れる
            .BackColor = cnsBC_Other
        End With
        days(dayi) = wDate + (dayi - (endDay + weekNo)) - 1
    Next

    YM_YEAR_MONTH_re nowCalendarDate               '年月ラベル更新
End With

End Sub
Private Sub YM_YEAR_MONTH_re(wDate As Date)
With fromCalendar
.cmbYMevent = False
.LBL_YM.Caption = Year(wDate) & "年" & Format(Month(wDate), "00") & "月"
.CBO_YEAR = Year(wDate) '年を指定
.CBO_MONTH = Month(wDate) '月を指定
.LBL_YM.Visible = True
.cmbYMevent = True
End With
End Sub

'-- イベント処理
Public Sub LblMonthClick(wmonth As Integer) '←(前月)→(翌月
calendarSet DateAdd("m", wmonth, nowCalendarDate)
End Sub
Public Sub LblYMClick() 'yyyy年mm月
fromCalendar.LBL_YM.Visible = False
End Sub
Public Sub CmbYMChange(wDate As Date) 'yyyy年mm月コンボ
calendarSet wDate
End Sub
Public Sub LblDDClick(i As Integer) '日選択
retarget.Value = days(i)
fromCalendar.Hide
End Sub
```

フォーム表示前に、表示位置をしています。追加したのは、ここです。
'''vba:変更
'----ユーザーフォーム表示位置--------------------------------------------------------------------
Dim lngLeft As Long ' 横位置
Dim lngTop As Long ' 縦位置
With fromCalendar
Call modCalendar5R.FP_GetFormPosition(target, .Width, .Height, lngLeft, lngTop) ' ユーザーフォーム表示位置取得
' フォーム表示位置の確認
If ((lngLeft <> 0) Or (lngTop <> 0)) Then
' 指定がある場合はマニュアル指定
.StartUpPosition = 0
.Left = lngLeft
.Top = lngTop
Else
' 指定がない場合はスクリーンの中央
.StartUpPosition = 2
End If
End With
'-----------------------------------------------------------------------------------------------
```

4.追加した　modCalendar5R　

基本的に変更しなくても使えるそうですが、modCalendar5R　の変更を最小限にするため
　239行目　Private Function FP_GetFormPosition(.... を Public にしました。

5.クラスモジュールも変更なし

カレンダ奮闘記はこれでおしまい。

物忘れ防止 calendar_v3_event.xlsm　calendar_v4_Class.xlsm　calendar_v5.xlsm
https://github.com/sugita0301/douzo