ExcelVBAでカレンダーコントロールを自作する【更新記事】（簡単に再現できます）

はじめに

エクセルで使えるカレンダーコントロールを作ります。

ボタンの配置などを含めてすべてコードに落とし込んでいるためコピーペーストのみで再現できます。そのため5分もかからず使えるようになります。

以前も同様の記事を書きました。
touch-sp.hatenablog.com
Excel 2019ではユーザーフォームのサイズなど少し変更する必要があったため今回更新記事を書きました。詳しい説明も追記しています。

作り方概略

やらなければいけないことは３つだけです。
【1】カレンダーフォーム「Calender」を追加する
【2】標準モジュール「CalenderModule」を追加する
【3】クラスモジュール「ControlSetting」を追加する

では詳細をみていきましょう。

作り方詳細

【1】カレンダーフォーム「Calender」を追加する

①まずはユーザーフォームを挿入します。

②ユーザーフォームの名前（オブジェクト名）を「UserForm1」から「Calender」に変更します。

③ユーザーフォーム「Calender」にコードを追加します。
「Calender」（下の図で青くなっているところ）を右クリックして「コードの表示」を選択して下さい。

右側に何も書いていないエディタが開かれるので以下をコピペして下さい。

Option Explicit

Private Sub UserForm_Initialize()

    'widthとinsidewidthの差は4.5 (5*2+30*7+12=232)
    Me.Width = 232
    Me.Height = 285
    
    Me.Caption = "カレンダー"
    
End Sub

これで3工程のうち1工程終了です。

【2】標準モジュール「CalenderModule」を追加する

①まずは標準モジュールを挿入します。

②標準モジュールの名前（オブジェクト名）を「Module1」から「CalenderModule」に変更します。

③標準モジュール「CalenderModule」にコードを追加します。
以下をコピペして下さい。

Option Explicit

Public calender_date As String

Function open_calender(ByVal text_date As String) As String
    
    Dim my_date As Date
    If (IsDate(text_date)) Then
        my_date = CDate(text_date)
    Else
        my_date = Date
    End If
    
    calender_date = text_date
    
    Load Calender
    
    Dim NewBtn(1 To 42) As Object
    Dim NewTxt As Object
    Dim NewCombo As Object
    Dim NewSpin As Object
    
    Dim days_label(0 To 6) As Object
    Dim obj1 As Object
    Dim obj2 As Object
    Dim obj3 As Object
    
    With Calender
        Set obj1 = .Controls.Add("Forms.Label.1", "year_label")
        Set obj2 = .Controls.Add("Forms.Label.1", "month_label")
        Set obj3 = .Controls.Add("Forms.Label.1", "year_month_label")
        
        With obj1
            .Height = 12
            .Width = 12
            .Font.Size = 12
            .Caption = "年"
            .Top = 21
            .Left = 90
        End With
        
        With obj2
            .Height = 12
            .Width = 12
            .Font.Size = 12
            .Caption = "月"
            .Top = 21
            .Left = 170
        End With
        
        With obj3
            .Height = 21
            .Width = 210
            .Font.Size = 16
            .Top = 55
            .Left = 5
            .SpecialEffect = fmSpecialEffectEtched
            .BackColor = RGB(255, 255, 255)
            .TextAlign = fmTextAlignCenter
        End With
        
        Dim i As Integer
        For i = 1 To 42
            Set NewBtn(i) = New ControlSetting
            Set NewBtn(i).myButton = .Controls.Add("Forms.CommandButton.1", "button" & i)
            With NewBtn(i).myButton
                .Height = 25
                .Width = 30
                .Top = 105 + ((i - 1) \ 7) * 25
                .Left = 5 + ((i - 1) Mod 7) * 30
                If (i - 1) Mod 7 = 0 Then .ForeColor = RGB(255, 0, 0)
                If (i - 1) Mod 7 = 6 Then .ForeColor = RGB(0, 0, 255)
            End With
        Next i
        
        Dim days As String
        days = "日月火水木金土"
        Dim days_i As Integer
        For days_i = 0 To 6
            Set days_label(days_i) = .Controls.Add("Forms.Label.1", "days_label" & days_i)
            With days_label(days_i)
                .Height = 18
                .Width = 30
                .Top = 87
                .Left = 5 + days_i * 30
                .Font.Size = 14
                .Font.Bold = True
                .TextAlign = fmTextAlignCenter
                .Caption = Mid(days, days_i + 1, 1)
                If days_i = 0 Then .ForeColor = RGB(255, 0, 0)
                If days_i = 6 Then .ForeColor = RGB(0, 0, 255)
            End With
        Next days_i
        
        Set NewTxt = New ControlSetting
        Set NewTxt.myTxt = .Controls.Add("Forms.TextBox.1", "year_txt")
        With NewTxt.myTxt
           .Height = 18
           .Width = 66
           .Top = 18
           .Left = 15
           .Font.Size = 12
           .TextAlign = fmTextAlignCenter
           .IMEMode = fmIMEModeDisable
           .Text = Year(my_date)
        End With
        
        Set NewCombo = New ControlSetting
        Set NewCombo.myCombo = .Controls.Add("Forms.ComboBox.1", "month_txt")
        With NewCombo.myCombo
            .Height = 18
            .Width = 48
            .Top = 18
            .Left = 115
            .Font.Size = 12
            .TextAlign = fmTextAlignCenter
            .Style = fmStyleDropDownCombo
            .ListRows = 12
             Dim month_i As Integer
             For month_i = 1 To 12
                 .AddItem month_i
             Next month_i
            .ListIndex = Month(my_date) - 1
        End With
         
        Set NewSpin = New ControlSetting
        Set NewSpin.mySpin = .Controls.Add("Forms.SpinButton.1", "updown")
        With NewSpin.mySpin
            .Height = 25.5
            .Width = 12.75
            .Top = 14
            .Left = 190
        End With
            
    End With
    
    Dim num As Integer
    Dim dd As String
    dd = Day(my_date)
    For num = 1 To 42
        If Calender.Controls("button" & num).Caption = dd And Calender.Controls("button" & num).Enabled Then
            Calender.Controls("button" & num).SetFocus
        End If
    Next num
    
    Calender.Show
    
    open_calender = calender_date
    
End Function
Function calender_hantei() As Boolean

    Dim kekka As Boolean
    
    If Not IsNumeric(Calender.Controls("year_txt").Text) Then
        kekka = False
    Else
        Calender.Controls("year_txt").Text = Int(Calender.Controls("year_txt").Text)
        kekka = True
    End If
    
    calender_hantei = kekka
  
End Function

Function calender_reload()

    Dim yy As Integer
    yy = Calender.Controls("year_txt").Text
    
    If yy < 1800 Then Exit Function
    If yy > 3000 Then Exit Function
    
    Dim button_i As Integer
    For button_i = 1 To 42
        Calender.Controls("button" & button_i).Caption = ""
        Calender.Controls("button" & button_i).Font.Size = 10
        Calender.Controls("button" & button_i).Enabled = False
    Next button_i
    
    Dim mm As Integer
    Dim d As Date
    Dim start_position As Integer
    Dim end_day As Integer
    
    yy = Calender.Controls("year_txt").Text
    mm = Calender.Controls("month_txt").Text
    Calender.Controls("year_month_label").Caption = yy & "年" & mm & "月"
    
    d = yy & "/" & mm & "/" & 1
    start_position = Weekday(d)

    Dim days_number As Integer '何日あるか
    days_number = Day(DateSerial(yy, mm + 1, 0))
    
    Dim start_day As Date
    start_day = d - (start_position - 1)
    Dim index As Integer
    For index = 1 To 42
        Calender.Controls("button" & index).Caption = Day(start_day + index - 1)
        If Month(start_day + index - 1) = mm Then
            Calender.Controls("button" & index).Font.Size = 12
            Calender.Controls("button" & index).Enabled = True
        End If
    Next index
        
End Function

これで3工程のうち2工程終了です。

【3】クラスモジュール「ControlSetting」を追加する

①まずはクラスモジュールを挿入します。

②クラスモジュールの名前（オブジェクト名）を「Class1」から「ControlSetting」に変更します。

③クラスモジュール「ControlSetting」にコードを追加します。
以下をコピペして下さい。

Option Explicit

Public WithEvents myButton As CommandButton
Public WithEvents myTxt As MSForms.TextBox
Public WithEvents myCombo As MSForms.ComboBox
Public WithEvents mySpin As MSForms.SpinButton

Private Sub myButton_Click()

    calender_date = Calender.Controls("year_month_label").Caption & myButton.Caption & "日"

    Unload Calender    

End Sub

Private Sub myTxt_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
     
    If KeyCode = vbKeyReturn Then
        Dim hantei As Boolean
        hantei = calender_hantei
        If Not (hantei) Then Exit Sub
        
        Call calender_reload
    End If

End Sub

Private Sub myCombo_Change()
    
    If Not (Me.myCombo.MatchFound) Then Exit Sub
    
    Dim hantei As Boolean
    hantei = calender_hantei
    If Not (hantei) Then Exit Sub
    
    Call calender_reload
    
End Sub

Private Sub mySpin_SpinDown()
    
    Dim hantei As Boolean
    hantei = calender_hantei
    If Not (hantei) Then Exit Sub
    
    Dim index As String
    index = Calender.Controls("month_txt").ListIndex
    If (index = -1) Then Exit Sub
    If (index = 0) Then
        Calender.Controls("year_txt").Text = Calender.Controls("year_txt").Text - 1
        index = 11
    Else
        index = index - 1
    End If
    Calender.Controls("month_txt").ListIndex = index
    
End Sub

Private Sub mySpin_SpinUp()

    Dim hantei As Boolean
    hantei = calender_hantei
    If Not (hantei) Then Exit Sub
    
    Dim index As String
    index = Calender.Controls("month_txt").ListIndex
    If (index = 11) Then
        Calender.Controls("year_txt").Text = Calender.Controls("year_txt").Text + 1
        index = 0
    Else
        index = index + 1
    End If
    Calender.Controls("month_txt").ListIndex = index
    
End Sub

これで全工程終了、完成です。

使い方

例としてワークシート「A1」に日付を入力します。
以下のマクロを実行してみて下さい。

Range("A1") = open_calender(Range("A1"))

選択しているセルに日付を入力する場合には以下のようになります。

ActiveCell = open_calender(ActiveCell)

左側がこれから入力するセルです。右側がカレンダーコントロールを開く時の基準となるセルです。
右側のセルが空白であれば現在の日付が基準となります。
過去の間隔が近い二日を入力するときにすでに入力された日付を基準にカレンダーコントロールを開くと便利です。
その場合には以下の様に二つのマクロを設定して下さい。

Sub A1に入力()
    Range("A1") = open_calender(Range("A2"))
End Sub

Sub A2に入力()
    Range("A2") = open_calender(Range("A1"))
End Sub

どちらを先に実行しても問題ありません。例えば一方のセル（「A1」）に1975年1月1日を入力するともう一方のセル（「A2」）に入力するときにこのようにカレンダーコントロールが開かれます。

動作環境

以下の環境で作成しています。

Windows 10
Office Home and Business 2019