EXCEL VBA日期选择器设计经验分享

Option ExplicitPrivate mYear As IntegerPrivate mMonth As IntegerPrivate mSelectedDate As Date'============================================================'  初始化'============================================================Private Sub UserForm_Initialize()    Dim wsD As Worksheet    Dim v As Variant    Me.Caption = "选择日期"    Set wsD = ThisWorkbook.Worksheets("营业日报")    v = wsD.Range("D5").Value    If IsDate(v) Then        mYear = Year(CDate(v))        mMonth = Month(CDate(v))        mSelectedDate = CDate(v)    Else        mYear = Year(Date)        mMonth = Month(Date)        mSelectedDate = Date    End If    RefreshListEnd Sub'============================================================'  刷新日期列表'============================================================Private Sub RefreshList()    Me.lblTitle.Caption = mYear & "年" & mMonth & "月"    Me.lstDays.Clear    Dim d As Date, lastDay As Date    Dim idx As Long    Dim wk As String    d = DateSerial(mYear, mMonth, 1)    lastDay = DateSerial(mYear, mMonth + 1, 0)    idx = -1    Do While d <= lastDay        Select Case Weekday(d, vbMonday)            Case 1: wk = "星期一"            Case 2: wk = "星期二"            Case 3: wk = "星期三"            Case 4: wk = "星期四"            Case 5: wk = "星期五"            Case 6: wk = "星期六"            Case 7: wk = "星期日"        End Select        Me.lstDays.AddItem Format(d, "yyyy-mm-dd") & "  " & wk        If d = mSelectedDate Then idx = Me.lstDays.ListCount - 1        d = d + 1    Loop    If idx >= 0 Then        Me.lstDays.ListIndex = idx    ElseIf Me.lstDays.ListCount > 0 Then        Me.lstDays.ListIndex = 0    End IfEnd Sub'============================================================'  上一月 / 下一月'============================================================Private Sub btnPrevMonth_Click()    mMonth = mMonth - 1    If mMonth < 1 Then        mMonth = 12        mYear = mYear - 1    End If    RefreshListEnd SubPrivate Sub btnNextMonth_Click()    mMonth = mMonth + 1    If mMonth > 12 Then        mMonth = 1        mYear = mYear + 1    End If    RefreshListEnd Sub'============================================================'  今天'============================================================Private Sub btnToday_Click()    mYear = Year(Date)    mMonth = Month(Date)    mSelectedDate = Date    RefreshListEnd Sub'============================================================'  列表双击 / 回车'============================================================Private Sub lstDays_DblClick(ByVal Cancel As MSForms.ReturnBoolean)    ConfirmSelectEnd SubPrivate Sub lstDays_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, _                            ByVal Shift As Integer)    If KeyCode = vbKeyReturn Then        ConfirmSelect        KeyCode = 0    End IfEnd Sub'============================================================'  按钮'============================================================Private Sub btnOK_Click()    ConfirmSelectEnd SubPrivate Sub btnCancel_Click()    Unload MeEnd Sub'============================================================'  确认：写入 D5'============================================================Private Sub ConfirmSelect()    Dim li As Long    Dim wsD As Worksheet    Dim cell As Range    li = Me.lstDays.ListIndex    If li < 0 Then        MsgBox "请选择一个日期。", vbExclamation, "提示"        Exit Sub    End If    mSelectedDate = DateSerial(mYear, mMonth, li + 1)    Set wsD = ThisWorkbook.Worksheets("营业日报")    Set cell = wsD.Range("D5")    If cell.MergeCells Then        cell.MergeArea.Cells(1, 1).Value = mSelectedDate        cell.MergeArea.Cells(1, 1).NumberFormatLocal = "yyyy年m月d日"    Else        cell.Value = mSelectedDate        cell.NumberFormatLocal = "yyyy年m月d日"    End If    Unload MeEnd Sub

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)    If Intersect(Target, Me.Range("D5")) Is Nothing Then Exit Sub    Cancel = True    frmDatePicker.Show vbModalEnd Sub