如何添加日历、日期选择器？答案

【问题标题】：How to add Calendar, Date-Picker?如何添加日历、日期选择器？
【发布时间】：2015-12-30 18:05:37
【问题描述】：

我需要在 Excel 2013 中添加日历日期选择器。

我发现 MonthView 和 DT Picker 不再位于 ActiveX 菜单中，并且据称包含这些内容的 CAB 文件的链接不起作用。有说明文档，但它们依赖于一个不存在的控件。

我有一个 Excel 插件可以做我想做的事，但我想用 VBA 来做，而不是在每台将使用它的机器上安装插件。

【问题讨论】：

标签： excel vba excel-2013

【解决方案1】：

一旦您注册了 mscomct2.ocx 控件（您需要在将使用此工作簿的所有计算机上注册此文件！），您可以添加一个工作表或用户窗体中的以下控件：

日期和时间选择器 (DTPicker)，屏幕截图的左侧/顶部
MonthView，屏幕截图的右侧/底部

工作表 (ActiveX)

在“开发人员”选项卡的“控件”组中，单击“插入”，然后单击右下角更多控件的按钮。
向下滚动并选择 Microsoft Date and Time Picker Control 6.0 (SP6) 或 Microsoft MonthView Control 6.0 (SP6)，然后单击 OK。
|
退出设计模式时，点击DTPicker控件是这样的，而MonthView占用空间较多：
|

用户表单

在选定用户窗体的工具箱中，右键单击控件选项卡的空白处，单击附加控件
向下滚动并勾选 Microsoft Date and Time Picker Control 6.0 (SP6) 或 Microsoft MonthView Control 6.0 (SP6)：
|
现在控件位于“控件”选项卡中以添加到用户窗体
用户窗体上控件的默认大小：

无论哪种方式，您都需要在单击这些控件时执行这些操作。

【讨论】：

这正是我需要的，但是正确的控件没有出现在我的控件列表中。有一个按钮提供“注册自定义”选项。当我导航到该文件时，一条错误消息指示“无法注册此控件”。现在呢？
@DonDesrosiers 你有什么版本的 mscomct2.ocx？我的是 6.1.98.16

【解决方案2】：

如果 Excel 格式不正确，某些用户可能无法使用您的 DatePicker。我开发的代码将创建一个 dateGetter 用户表单，将用户的日期选择作为全局变量获取，然后删除该表单。它应该与大多数系统兼容，尽管我没有在我自己的其他人身上测试过它。试一试。如果它对你有用，请大声告诉我......

2020 年 8 月：修复了小故障 - 选择使用表格打开的原始日期时，返回日期为“ 00:00:00 am” - 我在下面修复了该日期，以返回Label2标题中显示的日期。

另外 - MSForms 引用是 dateGetter() 子例程正常工作所必需的，否则在声明表单对象时会收到错误消息。我添加了另一个子例程，可以通过 VBA 代码添加该引用，或者在 VBA 编辑器中转到“工具 --> 引用”并选择 MSForms 引用。您必须在尝试运行 dateGetter 宏之前执行此操作。

Public absDate As Date ' This Public Variable is necessary to pass selected date

Sub setGUIDReferences()
'   NOTE:  The dateGetter() sub will not work until the MSForms Reference is added to this workbook project
'   You can add the MSForms reference by running this sub first
'   Or go to Tools --> References and select the MSForms reference there
'   included below are several other common references you can use for other projects just uncomment them to add
'   *************************************************************************************************************

    On Error Resume Next
    'ThisWorkbook.VBProject.References.AddFromGuid "{000204EF-0000-0000-C000-000000000046}", 0, 0    '       Visual Basic For Applications
    'ThisWorkbook.VBProject.References.AddFromGuid "{00020813-0000-0000-C000-000000000046}", 0, 0    '       Microsoft Excel 16.0 Object Library
    'ThisWorkbook.VBProject.References.AddFromGuid "{00020430-0000-0000-C000-000000000046}", 0, 0    '       OLE Automation
    'ThisWorkbook.VBProject.References.AddFromGuid "{2DF8D04C-5BFA-101B-BDE5-00AA0044DE52}", 0, 0    '       Microsoft Office 16.0 Object Library
    ThisWorkbook.VBProject.References.AddFromGuid "{0D452EE1-E08F-101A-852E-02608C4D0BB4}", 0, 0    '       Microsoft Forms 2.0 Object Library
    'ThisWorkbook.VBProject.References.AddFromGuid "{3050F1C5-98B5-11CF-BB82-00AA00BDCE0B}", 0, 0    '       Microsoft HTML Object Library
    'ThisWorkbook.VBProject.References.AddFromGuid "{EAB22AC0-30C1-11CF-A7EB-0000C05BAE0B}", 0, 0    '       Microsoft Internet Controls
    'ThisWorkbook.VBProject.References.AddFromGuid "{420B2830-E718-11CF-893D-00A0C9054228}", 0, 0    '       Microsoft Scripting Runtime
    'ThisWorkbook.VBProject.References.AddFromGuid "{86CF1D34-0C5F-11D2-A9FC-0000F8754DA1}", 0, 0    '       Microsoft Windows Common Controls-2 6.0 (SP6)
    'ThisWorkbook.VBProject.References.AddFromGuid "{4AFFC9A0-5F99-101B-AF4E-00AA003F0F07}", 0, 0    '       Microsoft Access 16.0 Object Library
    'ThisWorkbook.VBProject.References.AddFromGuid "{0002E157-0000-0000-C000-000000000046}", 0, 0    '       Microsoft Visual Basic for Applications Extensibility 5.3
    'ThisWorkbook.VBProject.References.AddFromGuid "{F5078F18-C551-11D3-89B9-0000F81FE221}", 0, 0    '       Microsoft MSXML2 for XML Scraping
    On Error GoTo 0
End Sub

Sub dateGetter()
'   This creates dategetter userform for those without access to date picker
'   Bug Fixed: Aug 2020, Selecting Original Date was resulting in 12:00:00 AM

'*********
'   Note: MSForms Reference in Tools menu must be added to workbook first before this calendar script will work
'   You can add several commonly used references by running the "setGUIDReferences()" subroutine above.
'   Or go to Tools --> References and select the MSForms reference there
'*********

Dim myForm As Object, calendarForm As Object, newLabel As MSForms.Label, newSpinner As MSForms.SpinButton
Dim NewFrame As MSForms.Frame
Dim NewButton As MSForms.CommandButton, newButton2 As MSForms.CommandButton
Dim NewListBox As MSForms.ListBox
Dim smallDayArray
Dim xDiff As Long
Dim smallTextArray
Dim startDate As Date
Dim endDate As Date
    
    Set myForm = ThisWorkbook.VBProject.VBComponents.Add(3)
    
    'Create the User Form
    With myForm
        .Properties("Caption") = "Select Date Range"
        .Properties("Width") = 247.5
        .Properties("Height") = 350
    End With
    
    'create button
    Set NewButton = myForm.designer.Controls.Add("Forms.commandbutton.1")
    With NewButton
        .Name = "CommandButton1"
        .Top = 288
        .Left = 138
        .Width = 42
        .Height = 24
        .Font.Size = 10
        .Font.Name = "Tahoma"
        .Caption = "Cancel"
    End With
    
    'create button
    Set NewButton = myForm.designer.Controls.Add("Forms.commandbutton.1")
    With NewButton
        .Name = "CommandButton2"
        .Top = 288
        .Left = 186
        .Width = 42
        .Height = 24
        .Font.Size = 10
        .Font.Name = "Tahoma"
        .Caption = "Select"
    End With
    
    
    'create frame
    Set NewFrame = myForm.designer.Controls.Add("Forms.frame.1")
    With NewFrame
        .Name = "Frame1"
        .Top = 54
        .Left = 24
        .Width = 192
        .Height = 180
        .Font.Size = 9
        .Font.Name = "Tahoma"
    End With
    
    'Create label1
    Set newLabel = myForm.designer.Controls.Add("Forms.Label.1")
    With newLabel
        .Name = "Label1"
        .Top = 30
        .Left = 30
        .Width = 102
        .Height = 18
        .Font.Size = 12
        .Font.Name = "Tahoma"
        .ForeColor = RGB(128, 0, 0)
        .BackColor = RGB(256, 256, 256)
        .Caption = "November 2017"
    End With
    
    'Create label2
    Set newLabel = myForm.designer.Controls.Add("Forms.Label.1")
    With newLabel
        .Name = "Label2"
        .Top = 258
        .Left = 36
        .Width = 174
        .Height = 18
        .Font.Size = 12
        .Font.Name = "Tahoma"
        .ForeColor = RGB(0, 0, 0)
        .Caption = "01/01/2017"
    End With
    
    
    'Create SpinButton1
    Set newSpinner = myForm.designer.Controls.Add("Forms.spinbutton.1")
    With newSpinner
        .Name = "SpinButton1"
        .Top = 24
        .Left = 144
        .Width = 12.75
        .Height = 25
    End With
    
    'Create Calendar Header Labels
    smallDayArray = Array("S", "M", "T", "W", "T", "F", "S")
    smallTextArray = Array("day1", "day2", "day3", "day4", "day5", "day6", "day7")
    xDiff = 18
    For i = LBound(smallDayArray) To UBound(smallDayArray)
        Set lbl = NewFrame.Controls.Add("Forms.Label.1")
        With lbl
            .Name = smallTextArray(i)
            .Top = 6
            .Left = xDiff
            .Width = 12
            .Height = 18
            .Font.Size = 11
            .Font.Name = "Tahoma"
            .Caption = smallDayArray(i)
        End With
        xDiff = xDiff + 24
    Next i
    
    'Create Calendar boxes labels
    arrCounter = 1
    For j = 1 To 6
        xDiff = 12
        For k = 1 To 7
            Set lbl = NewFrame.Controls.Add("Forms.Label.1")
            With lbl
                .Name = "lb_" & arrCounter
                Select Case j
                    Case 1
                        .Top = 24
                    Case 2
                        .Top = 48
                    Case 3
                        .Top = 72
                    Case 4
                        .Top = 96
                    Case 5
                        .Top = 120
                    Case 6
                        .Top = 144
                End Select
                .Left = xDiff
                .Width = 18
                .Height = 18
                .Font.Size = 11
                .Font.Name = "Tahoma"
                .Caption = " " & arrCounter
                .ForeColor = RGB(128, 0, 0)
                .BackColor = RGB(256, 256, 256)
            End With
            arrCounter = arrCounter + 1
            xDiff = xDiff + 24
        Next k
    Next j
    ''add code for form module
    myForm.codemodule.insertlines 1, "Private Sub CommandButton1_Click()"
    myForm.codemodule.insertlines 2, "absDate = 0"
    myForm.codemodule.insertlines 3, "Unload Me"
    myForm.codemodule.insertlines 4, "End Sub"
    myForm.codemodule.insertlines 5, ""
    myForm.codemodule.insertlines 6, "Private Sub SpinButton1_SpinDown()"
    myForm.codemodule.insertlines 7, "Dim newDate1 As Date"
    myForm.codemodule.insertlines 8, "    newDate1 = DateValue(Left(Label1.Caption, Len(Label1.Caption) - 5) & " & Chr(34) & " 1, " & Chr(34) & " & Right(Label1.Caption, 4))"
    myForm.codemodule.insertlines 9, "    newDate1 = DateAdd(" & Chr(34) & "m" & Chr(34) & ", -1, newDate1)"
    myForm.codemodule.insertlines 10, "    Label1.Caption = MonthName(Month(newDate1)) & " & Chr(34) & " " & Chr(34) & " & Year(newDate1)"
    myForm.codemodule.insertlines 11, "    Call clearBoxes"
    myForm.codemodule.insertlines 12, "   Run fillCal(newDate1)"
    myForm.codemodule.insertlines 13, "End Sub"
    myForm.codemodule.insertlines 14, "Private Sub SpinButton1_SpinUp()"
    myForm.codemodule.insertlines 15, "Dim newDate1 As Date"
    myForm.codemodule.insertlines 16, "    newDate1 = DateValue(Left(Label1.Caption, Len(Label1.Caption) - 5) & " & Chr(34) & " 1, " & Chr(34) & " & Right(Label1.Caption, 4))"
    myForm.codemodule.insertlines 17, "    newDate1 = DateAdd(" & Chr(34) & "m" & Chr(34) & ", 1, newDate1)"
    myForm.codemodule.insertlines 18, "    Label1.Caption = MonthName(Month(newDate1)) & " & Chr(34) & " " & Chr(34) & " & Year(newDate1)"
    myForm.codemodule.insertlines 19, "    Call clearBoxes"
    myForm.codemodule.insertlines 20, "    Run fillCal(newDate1)"
    myForm.codemodule.insertlines 21, "End Sub"
    myForm.codemodule.insertlines 22, "Function dhDaysInMonth2(Optional dtmDate As Date = 0) As Integer"
    myForm.codemodule.insertlines 23, "    ' Return the number of days in the specified month.  Written by Chip Pierson"
    myForm.codemodule.insertlines 24, "    If dtmDate = 0 Then"
    myForm.codemodule.insertlines 25, "        ' Did the caller pass in a date? If not, use"
    myForm.codemodule.insertlines 26, "        ' the current date."
    myForm.codemodule.insertlines 27, "        dtmDate = Date"
    myForm.codemodule.insertlines 28, "    End If"
    myForm.codemodule.insertlines 29, "    dhDaysInMonth2 = DateSerial(Year(dtmDate), _ "
    myForm.codemodule.insertlines 30, "     Month(dtmDate) + 1, 1) - _ "
    myForm.codemodule.insertlines 31, "     DateSerial(Year(dtmDate), Month(dtmDate), 1)"
    myForm.codemodule.insertlines 32, "End Function"
    myForm.codemodule.insertlines 33, "Public Sub UserForm_Activate()"
    myForm.codemodule.insertlines 34, "Dim currentDate As Date"
    myForm.codemodule.insertlines 35, ""
    myForm.codemodule.insertlines 36, " For i = 1 To 42" & vbNewLine
    myForm.codemodule.insertlines 37, "     txt = txt & " & Chr(34) & "Private Sub lb_" & Chr(34) & " & i & " & Chr(34) & "_Click()" & Chr(34) & " & vbNewLine" & vbNewLine
    myForm.codemodule.insertlines 38, "     txt = txt & " & Chr(34) & "Dim newDate As Date" & Chr(34) & " & vbNewLine" & vbNewLine
    myForm.codemodule.insertlines 39, " txt = txt & " & Chr(34) & "newDate = DateValue(Mid(Label1.Caption, 1, Len(Label1.Caption) - 5) &" & Chr(34) & " & Chr(34) &   " & Chr(34) & Chr(34) & " & lb_" & " & i & " & Chr(34) & ".Caption & " & Chr(34) & " & Chr(34) & " & Chr(34) & ", " & Chr(34) & " & Chr(34) & " & Chr(34) & " & Right(Label1.Caption, 4))" & Chr(34) & " & vbNewLine" & vbNewLine
    myForm.codemodule.insertlines 40, "     txt = txt & " & Chr(34) & "Label2.Caption = " & Chr(34) & " & Chr(34) & " & Chr(34) & "Date:  " & Chr(34) & " & Chr(34) & " & Chr(34) & " & newDate" & Chr(34) & " & vbNewLine" & vbNewLine
    myForm.codemodule.insertlines 41, "txt = txt & " & Chr(34) & "End Sub" & Chr(34) & " & vbNewLine" & vbNewLine
    myForm.codemodule.insertlines 42, "Next i" & vbNewLine
    myForm.codemodule.insertlines 43, ""
    myForm.codemodule.insertlines 44, "Label2.Caption =  Chr(34) &  Chr(34) "
    myForm.codemodule.insertlines 45, "currentDate = DateValue(Month(Date) & " & Chr(34) & " 1" & Chr(34) & " & " & Chr(34) & ", " & Chr(34) & " & Year(Date))"
    myForm.codemodule.insertlines 46, "Run fillCal(currentDate)"
    myForm.codemodule.insertlines 47, "End Sub"
    myForm.codemodule.insertlines 48, "Function fillCal(startDate As Date)"
    myForm.codemodule.insertlines 49, "Dim currentDayOfMonth As Integer, i As Integer"
    myForm.codemodule.insertlines 50, "currentDayOfMonth = Day(Date)"
    myForm.codemodule.insertlines 51, "Dim startCal As Date, currentMonth as Integer"
    myForm.codemodule.insertlines 52, "Dim labelArray, sumVar3 As Long"
    myForm.codemodule.insertlines 53, "    Label2.Caption = " & Chr(34) & "" & Chr(34)
    myForm.codemodule.insertlines 54, "    labelArray = Array(" & Chr(34) & "lb_1" & Chr(34) & ", " & Chr(34) & "lb_2" & Chr(34) & ", " & Chr(34) & "lb_3" & Chr(34) & ", " & Chr(34) & "lb_4" & Chr(34) & ", " & Chr(34) & "lb_5" _
                                                                & Chr(34) & ", " & Chr(34) & "lb_6" & Chr(34) & ", " & Chr(34) & "lb_7" & Chr(34) & ", " & Chr(34) & "lb_8" & Chr(34) & ", " & Chr(34) & "lb_9" & Chr(34) & ", " & Chr(34) _
                                                                & "lb_10" & Chr(34) & ", " & Chr(34) & "lb_11" & Chr(34) & ", " & Chr(34) & "lb_12" & Chr(34) & ", " & Chr(34) & "lb_13" & Chr(34) & ", " & Chr(34) & "lb_14" & Chr(34) & ", " & Chr(34) & "lb_15" & Chr(34) & ",  _"
    myForm.codemodule.insertlines 55, "                      " & Chr(34) & "lb_16" & Chr(34) & ", " & Chr(34) & "lb_17" & Chr(34) & ", " & Chr(34) & "lb_18" & Chr(34) & ", " & Chr(34) & "lb_19" & Chr(34) & ", " & Chr(34) & "lb_20" & Chr(34) & ", " & _
                                                                Chr(34) & "lb_21" & Chr(34) & ", " & Chr(34) & "lb_22" & Chr(34) & ", " & Chr(34) & "lb_23" & Chr(34) & ", " & Chr(34) & "lb_24" & Chr(34) & ", " & Chr(34) & "lb_25" & Chr(34) & ", " & _
                                                                Chr(34) & "lb_26" & Chr(34) & ", " & Chr(34) & "lb_27" & Chr(34) & ", " & Chr(34) & "lb_28" & Chr(34) & ", " & Chr(34) & "lb_29" & Chr(34) & ", " & Chr(34) & "lb_30" & Chr(34) & ", " & Chr(34) & "lb_31" & Chr(34) & ", _"
    myForm.codemodule.insertlines 56, "                      " & Chr(34) & "lb_32" & Chr(34) & ", " & Chr(34) & "lb_33" & Chr(34) & ", " & Chr(34) & "lb_34" & Chr(34) & ", " & Chr(34) & "lb_35" & Chr(34) & ", " & Chr(34) & "lb_36" & Chr(34) & ", " & _
                                                                Chr(34) & "lb_37" & Chr(34) & ", " & Chr(34) & "lb_38" & Chr(34) & ", " & Chr(34) & "lb_39" & Chr(34) & ", " & Chr(34) & "lb_40" & Chr(34) & ", " & Chr(34) & "lb_41" & Chr(34) & ", " & Chr(34) & "lb_42" & Chr(34) & ")"
    myForm.codemodule.insertlines 57, "    Label1 = MonthName(Month(startDate)) & " & Chr(34) & " " & Chr(34) & " & Year(startDate)"
    myForm.codemodule.insertlines 58, "    sumVar3 = Weekday(startDate) - 1"
    myForm.codemodule.insertlines 59, "    "
    myForm.codemodule.insertlines 60, "    For i = LBound(labelArray) To UBound(labelArray)"
    myForm.codemodule.insertlines 61, "            Me.Controls(labelArray(i)).Caption = " & Chr(34) & "" & Chr(34) & ""
    myForm.codemodule.insertlines 62, "    Next i"
    myForm.codemodule.insertlines 63, "    "
    myForm.codemodule.insertlines 64, "     For i = 1 To dhDaysInMonth2(startDate)"
    myForm.codemodule.insertlines 65, "         Me.Controls(labelArray(sumVar3)).Caption = i"
    myForm.codemodule.insertlines 66, "         If currentDayOfMonth = i And month(Date) = Month(StartDate)  And Year(Date) = Year(StartDate) Then"
    myForm.codemodule.insertlines 67, "             Me.Controls(labelArray(sumVar3)).BackColor = RGB(256, 0, 0)"
    myForm.codemodule.insertlines 68, "             Me.Controls(labelArray(sumVar3)).ForeColor = RGB(256, 256, 256)"
    myForm.codemodule.insertlines 69, "             Label2.Caption = " & Chr(34) & "Date:  " & Chr(34) & " & DateValue(Month(startDate) & " & Chr(34) & "/" & Chr(34) & " & i & " & Chr(34) & "/" & Chr(34) & " & Year(startDate))"
    myForm.codemodule.insertlines 70, "        End If"
    myForm.codemodule.insertlines 71, "        sumVar3 = sumVar3 + 1"
    myForm.codemodule.insertlines 72, "     Next i"
    myForm.codemodule.insertlines 73, "    "
    myForm.codemodule.insertlines 74, "End Function"
    myForm.codemodule.insertlines 75, "Private Sub CommandButton2_Click()"
    myForm.codemodule.insertlines 76, "    absDate = Replace(Me.Label2.Caption, " & Chr(34) & "Date:  " & Chr(34) & ", " & Chr(34) & Chr(34) & "):Unload Me"
    myForm.codemodule.insertlines 77, "End Sub"
    myForm.codemodule.insertlines 78, "Private Sub clearBoxes()"
    myForm.codemodule.insertlines 79, "Dim labelArray"
    myForm.codemodule.insertlines 80, "     Label2.Caption = " & Chr(34) & "" & Chr(34)
    myForm.codemodule.insertlines 81, "    labelArray = Array(" & Chr(34) & "lb_1" & Chr(34) & ", " & Chr(34) & "lb_2" & Chr(34) & ", " & Chr(34) & "lb_3" & Chr(34) & ", " & Chr(34) & "lb_4" & Chr(34) & ", " & Chr(34) & "lb_5" _
                                                                & Chr(34) & ", " & Chr(34) & "lb_6" & Chr(34) & ", " & Chr(34) & "lb_7" & Chr(34) & ", " & Chr(34) & "lb_8" & Chr(34) & ", " & Chr(34) & "lb_9" & Chr(34) & ", " & Chr(34) _
                                                                & "lb_10" & Chr(34) & ", " & Chr(34) & "lb_11" & Chr(34) & ", " & Chr(34) & "lb_12" & Chr(34) & ", " & Chr(34) & "lb_13" & Chr(34) & ", " & Chr(34) & "lb_14" & Chr(34) & ", " & Chr(34) & "lb_15" & Chr(34) & ",  _"
    myForm.codemodule.insertlines 82, "                      " & Chr(34) & "lb_16" & Chr(34) & ", " & Chr(34) & "lb_17" & Chr(34) & ", " & Chr(34) & "lb_18" & Chr(34) & ", " & Chr(34) & "lb_19" & Chr(34) & ", " & Chr(34) & "lb_20" & Chr(34) & ", " & _
                                                                Chr(34) & "lb_21" & Chr(34) & ", " & Chr(34) & "lb_22" & Chr(34) & ", " & Chr(34) & "lb_23" & Chr(34) & ", " & Chr(34) & "lb_24" & Chr(34) & ", " & Chr(34) & "lb_25" & Chr(34) & ", " & _
                                                                Chr(34) & "lb_26" & Chr(34) & ", " & Chr(34) & "lb_27" & Chr(34) & ", " & Chr(34) & "lb_28" & Chr(34) & ", " & Chr(34) & "lb_29" & Chr(34) & ", " & Chr(34) & "lb_30" & Chr(34) & ", " & Chr(34) & "lb_31" & Chr(34) & ", _"
    myForm.codemodule.insertlines 83, "                      " & Chr(34) & "lb_32" & Chr(34) & ", " & Chr(34) & "lb_33" & Chr(34) & ", " & Chr(34) & "lb_34" & Chr(34) & ", " & Chr(34) & "lb_35" & Chr(34) & ", " & Chr(34) & "lb_36" & Chr(34) & ", " & _
                                                                Chr(34) & "lb_37" & Chr(34) & ", " & Chr(34) & "lb_38" & Chr(34) & ", " & Chr(34) & "lb_39" & Chr(34) & ", " & Chr(34) & "lb_40" & Chr(34) & ", " & Chr(34) & "lb_41" & Chr(34) & ", " & Chr(34) & "lb_42" & Chr(34) & ")"
    myForm.codemodule.insertlines 84, "      For i = lbound(labelArray) to ubound(labelArray)"
    myForm.codemodule.insertlines 85, "         Me.Controls(labelArray(i)).BackColor = RGB(256, 256, 256)"
    myForm.codemodule.insertlines 86, "         Me.Controls(labelArray(i)).ForeColor = RGB(0, 0, 0)"
    myForm.codemodule.insertlines 87, "      next i"
    myForm.codemodule.insertlines 88, "End Sub"
    '   add click controls for date label boxes
    Dim myCounter As Long
    myCounter = 89
        For i = 1 To 42
            myForm.codemodule.insertlines myCounter, "Private Sub lb_" & i & "_Click()"
            myCounter = myCounter + 1
            myForm.codemodule.insertlines myCounter, "Dim newDate As Date"
            myCounter = myCounter + 1
            myForm.codemodule.insertlines myCounter, "Call clearBoxes"
            myCounter = myCounter + 1
            myForm.codemodule.insertlines myCounter, "absDate = DateValue(Left(Label1.Caption, Len(Label1.Caption) - 5) & " & Chr(34) & Chr(32) & Chr(34) & " & lb_" & i & ".Caption & " & Chr(34) & ", " & Chr(34) & Chr(38) & " Right(Label1.Caption, 4))"
            myCounter = myCounter + 1
            myForm.codemodule.insertlines myCounter, "Label2.Caption = " & Chr(34) & "Date:  " & Chr(34) & " & absDate" & vbNewLine
            myCounter = myCounter + 1
            myForm.codemodule.insertlines myCounter, "lb_" & i & ".backcolor = rgb(256,0,0)"
            myCounter = myCounter + 1
            myForm.codemodule.insertlines myCounter, "lb_" & i & ".forecolor = rgb(256,256,256)"
            myCounter = myCounter + 1
            myForm.codemodule.insertlines myCounter, "End Sub" & vbNewLine
            myCounter = myCounter + 1
    Next i
    'Add and show new userform
    absDate = Format(Date, "mm/dd/yyyy")
    Set calendarForm = VBA.UserForms.Add(myForm.Name)
    calendarForm.Show
    
    
    If absDate <> 0 Then
    '   Here is where you put your code to to use the selected date
    '   whhich is in the global variabole "absDate"
        startDate = absDate
        Debug.Print "Your First Date is " & startDate
    Else
        Beep
        MsgBox "You did not select a date"
        GoTo endItAll
    End If
    
    
     
endItAll:
    '   Uncomment the following line if you want to delete the form after using it
    ThisWorkbook.VBProject.VBComponents.Remove myForm
End Sub
Function dhDaysInMonth(Optional dtmDate As Date = 0) As Integer
    ' Return the number of days in the specified month.  Written by Chip Pierson
    If dtmDate = 0 Then
        ' Did the caller pass in a date? If not, use
        ' the current date.
        dtmDate = Date
    End If
    dhDaysInMonth2 = DateSerial(Year(dtmDate), _
     Month(dtmDate) + 1, 1) - _
     DateSerial(Year(dtmDate), Month(dtmDate), 1)
End Function

【讨论】：

我喜欢你在这段代码中所做的事情，并且你正在使用 Chip Pierson 代码。我很惊讶它没有得到更高的评价，但我想没有人意识到你在做什么。
Chip Pierson 绝对是个天才，在日期和日期数学方面帮助了我很大。 Chip 有一个关于假期和其他工作周功能的精彩部分。虽然我在这里使用了他的一些代码（并给了他荣誉），但大部分代码是我的代码，旨在实现手工日期选择器的可移植性。在我的工作中，有些电台没有我的电台拥有的所有参考资料，如果电台没有那个 GUID，普通的 EXCEL 日期选择器将无法工作。这个似乎工作正常，敲木头。
此外，如果您删除“ThisWorkbook.VBProject.VBComponents.Remove myForm”行，则不会删除该表单。然后，您可以通过 .show 命令将该表单用作任何其他类型的表单。
是的，我看到了。我以您的代码为基础并将其集成到假期跟踪工具中，以展示 VBA 的强大功能。这很可悲，但感觉就像美国企业正在远离我喜欢的 VBA。我现在正在大力推动使用 R，它实际上并没有更好，并且没有几乎那么强大的错误处理。
我自己的问题是可移植性。这就是为什么我构建了这个通用的即时日历用户表单。我公司的每个人都有 MS Office。不同的版本或一些有必要的参考资料，而另一些则没有。那些没有参考资料的人只会得到错误，因此认为 VBA 是一堆废话。（还有我作为程序员的能力。）所以我猜这就是 MS 远离它的原因。但这是 Excel 系统的错，不是我们的错。他们的错误系统应该提醒用户缺少引用以及如何获取它或使引用可移植到单独的模块中。

【解决方案3】：

我使用 mscomct2.ocx 文件在 Excel 中使用日期选择器。您需要注册它，然后才能轻松使用日期选择器

【讨论】：

这可能是我对 windows 的普遍无知，但我无法注册此文件。它甚至没有出现在我的系统 32 文件夹中。即使我从下载中复制它。我对应该非常简单的事情感到沮丧。我在 Mac 上使用 fusion，但我无法想象这是问题
@DonDesrosiers 要注册 mscomct2.ocx，首先以管理员身份打开命令提示符，然后输入 regsvr32 /s "C:\Windows\SysWOW64\mscomct2.ocx"，假设这是您复制到的路径。
好的。谢谢。那行得通。但核心问题依然存在。我在 activeX 控件中看不到日历日期选择器。假设你知道它叫什么，我仍然需要帮助来设置它。叹息。

【解决方案4】：

在 VBA Excel 模块中使用 DTPicker（日期选择器）元素会使您的工作无法共享。这发生在我身上很多次。我通常与朋友分享我的作品，但每当遇到 DTPicker 缺少库的问题时，他们都无法继续。

安装 Microsoft Common Control 2 SP6 然后注册它的服务并不是每个人都可以的。因此，我没有使用 DTPicker 元素，而是开发了自己的日期选择器，它更方便、容易和适用。

这是表单文件的链接。 https://www.dropbox.com/s/bwxtkw03kytcv8v/Form%20Files.rar?dl=0

使用此表单的步骤

导入
现在，在您的 USERFORM 中，在日期区域（文本框）中，通过双击事件执行我的表单文件。

enter image description here

【讨论】：

【解决方案5】：

作为 DTPicker 控件的替代方法，可以使用用户窗体轻松地将日期添加到活动单元格。

双击工作表上的任何单元格时会显示日历表单。从用户窗体标题上的月份开始，根据用户的系统语言在组合框控件中列出月份。

用户窗体上单击按钮的 ControlTipText 值作为日期添加到活动单元格中。

Source (sample file can be downloaded here)

【讨论】：