【完成品】エクセルVBAでカレンダーフォームを作成してみた

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
          
    If Target.Address <> "$A$1" Then
       
        frmCalendar.Hide
        Exit Sub
        
    End If
    
    Set frmCalendar.TargetRange = Target
    frmCalendar.Initialize
    frmCalendar.Show vbModeless
    
End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
        
    '範囲選択を無視
    If Target.Count > 1 Then
        frmCalendar.Hide
        Exit Sub
    End If

    '日付の入力欄以外を無視
    If Target.Column <> Hoge Then
        frmCalendar.Hide
        Exit Sub
    End If

    If Target.row <= Fuga Then
        frmCalendar.Hide
        Exit Sub
    End If

    Set frmCalendar.TargetRange = Target
    frmCalendar.Initialize
    frmCalendar.Show vbModeless
    
End Sub

Option Explicit

Private Const COLOR_NORMAL = &HE0E0E0
Private Const COLOR_TODAY = &H99FFFF

Public TargetRange As Range

Public Sub Initialize()

    Dim dt As Date
    
    If IsDate(TargetRange.value) = False Then
        dt = Date
    Else
        dt = TargetRange.value
    End If

    SetCalendar year(dt), month(dt)

End Sub

Private Sub lblPreMonth_Click()

    MovePreMonth
    
End Sub

Private Sub lblPreMonth_DblClick(ByVal Cancel As MSForms.ReturnBoolean)

    MovePreMonth
    
End Sub

Private Sub MovePreMonth()

    Dim dt As Date
    dt = DateSerial(lblYear.Caption, lblMonth.Caption - 1, 1)

    SetCalendar year(dt), month(dt)
    
End Sub

Private Sub lblNextMonth_Click()

    MoveNextMonth
    
End Sub

Private Sub lblNextMonth_DblClick(ByVal Cancel As MSForms.ReturnBoolean)

    MoveNextMonth

End Sub

Private Sub MoveNextMonth()

    Dim dt As Date
    dt = DateSerial(lblYear.Caption, lblMonth.Caption + 1, 1)

    SetCalendar year(dt), month(dt)

End Sub

Private Sub SetCalendar(ByVal year As Integer, ByVal month As Integer)

    '年月を表示
    lblYear.Caption = year
    lblMonth.Caption = month

    Dim i As Integer
    Dim lblDay As Object
    
    'カレンダーを初期化
    For i = 1 To 37
    
        Set lblDay = Me.Controls("lblDay" & i)
        
        lblDay.Caption = ""
        lblDay.BackColor = COLOR_NORMAL
        
    Next

    '始めの日
    Dim firstDate As Date
    firstDate = DateSerial(year, month, 1)
    
    '曜日によって位置をずらす
    Dim position As Integer
    position = weekday(firstDate) - 1
    
    '終わりの日
    Dim endDay As Integer
    endDay = day(DateSerial(year, month + 1, 0))
    
    For i = 1 To endDay
    
        Set lblDay = Me.Controls("lblDay" & (i + position))
        
        lblDay.Caption = i
        
        If DateSerial(year, month, i) = Date Then
            lblDay.BackColor = COLOR_TODAY
        End If
    
    Next
    
End Sub

Private Sub OutputDate(ByVal day As String)

    If day = "" Then
        Exit Sub
    End If
    
    TargetRange.value = DateSerial(lblYear.Caption, lblMonth.Caption, day)

    Me.Hide

End Sub

Private Sub lblDay1_Click()

    OutputDate lblDay1.Caption

End Sub

Private Sub lblDay2_Click()

    OutputDate lblDay2.Caption

End Sub

'以下省略　lblDay31_Click()まで続く

Private Sub UserForm_Layout()

    'フォームの位置が変わった場合は、
    '再表示時にその位置を復元する
    StartUpPosition = 0
    
End Sub

Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)

    '表示位置がリセットされないようにする
    Cancel = True
    Me.Hide

End Sub