Excel VBA日历，dateselect器

我需要在Excel2013中添加日历dateselect器。 我认为这很容易，直到我发现MonthView和DT Picker不再在ActiveX菜单中，并且包含这些的CAB文件的链接不起作用。 那里有一些看似优秀的教学文档，但是他们依赖于不存在的控制。 我目前有一个Excel插件，做我想做的事情，但我想用VBA做到这一点，而不是在每台将使用此插件的机器上安装插件。 有任何想法吗？

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

  • date和时间select器（ DTPicker ），左边/截图的顶部
  • MonthView ，右侧/底部的截图

工作表（ActiveX）

  1. 在“开发工具”选项卡的“控件”组中，单击“插入”，然后右下angular的“更多”
    步骤1
  2. 向下滚动并selectMicrosoftdate和时间选取器控制6.0（SP6）或Microsoft MonthView控制6.0（SP6），然后单击确定。
    Step2a | Step2b
  3. 当您不在devise模式时，单击DTPicker控件是这样的，而MonthView需要更多的空间：
    Step3a | Step3b

用户窗体

  1. 在所选用户窗体的工具箱中，右键单击控件选项卡的空白区域，单击其他控件
    形成步骤1
  2. 向下滚动并选中Microsoftdate和时间选取器控制6.0（SP6）或Microsoft MonthView控制6.0（SP6） ：
    形成步骤2a | 形成步骤2b
  3. 现在这些控件位于“控件”选项卡中，以在用户窗体上添加
    形成第3步
  4. 用户窗体上控件的默认大小：
    形成第四步

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

我已经使用mscomct2.ocx文件在Excel中使用dateselect器。 你需要注册它，然后可以很容易地使用dateselect器

如果Excel格式不正确，某些用户可能无法使用DatePicker。 我开发的代码将创build一个dateGetter用户窗体，获取用户的dateselect作为全局variables，然后删除窗体。 它应该与大多数系统兼容，虽然我还没有在我自己的系统上testing过。 试一试。 如果它适合你，给我一个呼喊…. 

 Public absDate As Date Sub dateGetter() ' This creates dategetter userform for those without access to date picker 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, "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_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 84, " " & 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 85, " For i = lbound(labelArray) to ubound(labelArray)" myForm.codemodule.insertlines 86, " Me.Controls(labelArray(i)).BackColor = RGB(256, 256, 256)" myForm.codemodule.insertlines 87, " Me.Controls(labelArray(i)).ForeColor = RGB(0, 0, 0)" myForm.codemodule.insertlines 88, " next i" myForm.codemodule.insertlines 89, "End Sub" ' add click controls for date label boxes Dim myCounter As Long myCounter = 90 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 = 0 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 ' If you would like to get a second date ( for range of dates) before the form is deleted ' then just add this code absDate = 0 Set calendarForm = VBA.UserForms.Add(myForm.Name) calendarForm.Show If absDate <> 0 Then ' put additional code here for the second date endDate = absDate Debug.Print "Your Second Date is " & endDate Else Beep MsgBox "You did not select a date" 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

使用VBA Excel模块中的DTPicker（Date Picker）元素使您的工作变得不稳定。 这发生在我身上多次。 我通常与同伴分享我的作品，并且无法在遇到DTPicker丢失的库问题时无法继续。

安装Microsoft Common Control 2 SP6然后注册它的服务不是每个人的一杯茶。 所以，而不是使用DTPicker元素，我开发了我自己的date选取器，这是更方便，简单和适用。

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

使用此表单的步骤

  1. 导入它
  2. 现在，在您的USERFORM中，在date区域（文本框）中，通过双击事件来执行我的表单文件。

在这里input图像说明

Interesting Posts

从父应用程序断开VBA UserForm

为重复的Excel行创build唯一的ID号

正则expression式获取一个URL Excel的VB的域名

RFM分割Excel采取中等价值

在Excel中用多个条件进行排名

错误“HTTP 403网站拒绝显示此网页”在Excel vba浏览URL

如果未安装msoffice，如何在我的c＃应用程序中创buildexcel

使用百分比标签和实际值数据表显示数据透视表

如何在Excel文档中添加当前时间范围的单元格

如何将所有邮件从Outlook导出到Excel的特定文件夹