excel - 在 VBA 的文本框中格式化 MM/DD/YYYY 日期

Question

我正在寻找一种方法来自动将 VBA 文本框中的日期格式化为 MM/DD/YYYY 格式，并且我希望它在用户输入时格式化。例如，一旦用户输入第二个数字，程序会自动输入一个“/”。现在，我使用以下代码使这个工作（以及第二个破折号）：

Private Sub txtBoxBDayHim_Change()
    If txtBoxBDayHim.TextLength = 2 or txtBoxBDayHim.TextLength = 5 then
    txtBoxBDayHim.Text = txtBoxBDayHim.Text + "/"
End Sub

现在，这在打字时效果很好。但是，当尝试删除时，它仍然进入破折号，因此用户不可能删除超过一个破折号（删除破折号会导致长度为 2 或 5，然后再次运行 sub，添加另一个破折号）。关于更好的方法来做到这一点的任何建议？

score 64 · Accepted Answer

我从不建议使用文本框或输入框来接受日期。很多事情都可能出错。我什至不建议您使用日历控件或日期选择器，因为您需要注册 mscal.ocx 或 mscomct2.ocx，这非常痛苦，因为它们不是可自由分发的文件。

这是我推荐的。您可以使用此自定义日历来接受用户的日期

优点：

您不必担心用户输入错误信息
您不必担心用户在文本框中粘贴
您不必担心编写任何主要代码
有吸引力的图形用户界面
可以很容易地整合到您的应用程序中
不使用您需要引用任何库（如 mscal.ocx 或 mscomct2.ocx）的任何控件

缺点：

嗯……嗯……想不出来……

如何使用它（我的保管箱中缺少文件。请参阅帖子底部以获取日历的升级版本）

从这里下载Userform1.frm和。Userform1.frx
在您的 VBA 中，只需Userform1.frm如下图所示导入即可。

导入表格

在此处输入图像描述

运行它

您可以在任何过程中调用它。例如

Sub Sample()
    UserForm1.Show
End Sub

屏幕截图在行动

在此处输入图像描述

注意：您可能还希望看到将日历提升到新的水平

score 36 · Accepted Answer

这与 Siddharth Rout 的答案相同。但我想要一个可以完全定制的日期选择器，以便可以根据正在使用的任何项目定制外观和感觉。

您可以单击此链接下载我想出的自定义日期选择器。下面是一些正在运行的表单的屏幕截图。

三个示例日历

要使用日期选择器，只需将 CalendarForm.frm 文件导入您的 VBA 项目。上面的每个日历都可以通过一个函数调用获得。结果仅取决于您使用的参数（所有这些都是可选的），因此您可以根据需要自定义它的大小。

比如左边最基本的日历可以通过下面这行代码得到：

MyDateVariable = CalendarForm.GetDate

这里的所有都是它的。从那里，您只需包含要获取所需日历的任何参数。下面的函数调用将生成右侧的绿色日历：

MyDateVariable = CalendarForm.GetDate( _
    SelectedDate:=Date, _
    DateFontSize:=11, _
    TodayButton:=True, _
    BackgroundColor:=RGB(242, 248, 238), _
    HeaderColor:=RGB(84, 130, 53), _
    HeaderFontColor:=RGB(255, 255, 255), _
    SubHeaderColor:=RGB(226, 239, 218), _
    SubHeaderFontColor:=RGB(55, 86, 35), _
    DateColor:=RGB(242, 248, 238), _
    DateFontColor:=RGB(55, 86, 35), _
    SaturdayFontColor:=RGB(55, 86, 35), _
    SundayFontColor:=RGB(55, 86, 35), _
    TrailingMonthFontColor:=RGB(106, 163, 67), _
    DateHoverColor:=RGB(198, 224, 180), _
    DateSelectedColor:=RGB(169, 208, 142), _
    TodayFontColor:=RGB(255, 0, 0), _
    DateSpecialEffect:=fmSpecialEffectRaised)

以下是它所包含的一些功能的简单介绍。所有选项都完整记录在用户表单模块本身中：

使用方便。用户窗体是完全独立的，可以导入到任何 VBA 项目中，并且无需太多额外的编码即可使用。
简单，有吸引力的设计。
完全可定制的功能、尺寸和配色方案
将用户选择限制在特定日期范围内
选择任何一天作为一周的第一天
包括周数，并支持 ISO 标准
单击标题中的月份或年份标签会显示可选的组合框
当您将鼠标悬停在日期上时，日期会改变颜色

score 11 · Accepted Answer

添加一些东西来跟踪长度，并允许您“检查”用户是否正在添加或减去文本。这目前未经测试，但类似的东西应该可以工作（特别是如果你有一个用户表单）。

'add this to your userform or make it a static variable if it is not part of a userform
private oldLength as integer

Private Sub txtBoxBDayHim_Change()
    if ( oldlength > txboxbdayhim.textlength ) then
        oldlength =txtBoxBDayHim.textlength
        exit sub
    end if

    If txtBoxBDayHim.TextLength = 2 or txtBoxBDayHim.TextLength = 5 then
    txtBoxBDayHim.Text = txtBoxBDayHim.Text + "/"
    end if
    oldlength =txtBoxBDayHim.textlength
End Sub

score 7 · Accepted Answer

我也以一种或另一种方式偶然发现了同样的困境，为什么 Excel VBA 没有Date Picker. 感谢 Sid，他出色地完成了为我们所有人创造一些东西的工作。

尽管如此，我还是到了需要自己创作的地步。我把它贴在这里是因为我确信很多人都会登陆这篇文章并从中受益。

我所做的和 Sid 所做的一样简单，只是我不使用临时工作表。我认为计算非常简单直接，因此无需将其转储到其他地方。这是日历的最终输出：

在此处输入图像描述

如何设置：

创建 42 个Label控件并按顺序命名并从左到右、从上到下排列（此标签包含上面的灰色25到灰色5）。Label将控件的名称更改为Label_01、Label_02等。将所有 42 个标签Tag属性设置为dts.
Label为标题创建另外 7 个控件（这将包含Su、Mo、Tu...）
再创建 2 个Label控件，一个用于水平线（高度设置为 1），一个用于月和年显示。Label将用于显示月份和年份的名称命名为Label_MthYr
插入 2 个Image控件，一个包含左侧图标以滚动上个月，一个包含滚动下个月（我更喜欢简单的左右箭头图标）。命名它Image_Left并Image_Right

布局应该或多或少像这样（我将创造力留给任何使用它的人）。

在此处输入图像描述

声明：
我们需要在最顶部声明一个变量来保存当前选择的月份。

Option Explicit
Private curMonth As Date

私有过程和函数：

Private Function FirstCalSun(ref_date As Date) As Date
    '/* returns the first Calendar sunday */
    FirstCalSun = DateSerial(Year(ref_date), _
                  Month(ref_date), 1) - (Weekday(ref_date) - 1)
End Function

Private Sub Build_Calendar(first_sunday As Date)
    '/* This builds the calendar and adds formatting to it */
    Dim lDate As MSForms.Label
    Dim i As Integer, a_date As Date

    For i = 1 To 42
        a_date = first_sunday + (i - 1)
        Set lDate = Me.Controls("Label_" & Format(i, "00"))
        lDate.Caption = Day(a_date)
        If Month(a_date) <> Month(curMonth) Then
            lDate.ForeColor = &H80000011
        Else
            If Weekday(a_date) = 1 Then
                lDate.ForeColor = &HC0&
            Else
                lDate.ForeColor = &H80000012
            End If
        End If
    Next
End Sub

Private Sub select_label(msForm_C As MSForms.Control)
    '/* Capture the selected date */
    Dim i As Integer, sel_date As Date
    i = Split(msForm_C.Name, "_")(1) - 1
    sel_date = FirstCalSun(curMonth) + i

    '/* Transfer the date where you want it to go */
    MsgBox sel_date

End Sub

图像事件：

Private Sub Image_Left_Click()

    If Month(curMonth) = 1 Then
        curMonth = DateSerial(Year(curMonth) - 1, 12, 1)
    Else
        curMonth = DateSerial(Year(curMonth), Month(curMonth) - 1, 1)
    End If

    With Me
        .Label_MthYr.Caption = Format(curMonth, "mmmm, yyyy")
        Build_Calendar FirstCalSun(curMonth)
    End With

End Sub

Private Sub Image_Right_Click()

    If Month(curMonth) = 12 Then
        curMonth = DateSerial(Year(curMonth) + 1, 1, 1)
    Else
        curMonth = DateSerial(Year(curMonth), Month(curMonth) + 1, 1)
    End If

    With Me
        .Label_MthYr.Caption = Format(curMonth, "mmmm, yyyy")
        Build_Calendar FirstCalSun(curMonth)
    End With

End Sub

我添加了这个以使它看起来像用户正在单击标签并且也应该在Image_Right控件上完成。

Private Sub Image_Left_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, _
                                 ByVal X As Single, ByVal Y As Single)
    Me.Image_Left.BorderStyle = fmBorderStyleSingle
End Sub

Private Sub Image_Left_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, _
                               ByVal X As Single, ByVal Y As Single)
    Me.Image_Left.BorderStyle = fmBorderStyleNone
End Sub

标签事件： 所有 42 个标签 ( to )
都应完成所有这些操作提示：构建前 10 个标签，然后对剩余的标签使用查找和替换。Label_01Lable_42

Private Sub Label_01_Click()
    select_label Me.Label_01
End Sub

这是为了悬停在日期和点击效果。

Private Sub Label_01_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, _
                               ByVal X As Single, ByVal Y As Single)
    Me.Label_01.BorderStyle = fmBorderStyleSingle
End Sub

Private Sub Label_01_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, _
                               ByVal X As Single, ByVal Y As Single)
    Me.Label_01.BackColor = &H8000000B
End Sub

Private Sub Label_01_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, _
                             ByVal X As Single, ByVal Y As Single)
    Me.Label_01.BorderStyle = fmBorderStyleNone
End Sub

用户窗体事件：

Private Sub UserForm_Initialize()
    '/* This is to initialize everything */
    With Me
        curMonth = DateSerial(Year(Date), Month(Date), 1)
        .Label_MthYr = Format(curMonth, "mmmm, yyyy")
        Build_Calendar FirstCalSun(curMonth)
    End With

End Sub

同样，只是为了悬停日期效果。

Private Sub UserForm_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, _
                               ByVal X As Single, ByVal Y As Single)

    With Me
        Dim ctl As MSForms.Control, lb As MSForms.Label

        For Each ctl In .Controls
            If ctl.Tag = "dts" Then
                Set lb = ctl: lb.BackColor = &H80000005
            End If
        Next
    End With

End Sub

就是这样。这是原始的，您可以在其中添加自己的扭曲。
我已经使用了一段时间，并且没有任何问题（性能和功能方面）。
还没有Error Handling，但我想可以很容易地管理。
实际上，没有效果，代码太短了。
您可以管理您的日期在select_label程序中的去向。HTH。

score 2 · Accepted Answer

您也可以在文本框上使用输入掩码。如果您将掩码设置为##/##/####，它将始终在您键入时进行格式化，并且您无需进行任何编码，只需检查输入的日期是否为真实日期。

简单的几行

txtUserName.SetFocus
If IsDate(txtUserName.text) Then
    Debug.Print Format(CDate(txtUserName.text), "MM/DD/YYYY")
Else
    Debug.Print "Not a real date"
End If

score 2 · Accepted Answer

为了快速解决，我通常这样做。

这种方法将允许用户在文本框中以他们喜欢的任何格式输入日期，最后在完成编辑后以 mm/dd/yyyy 格式输入日期。所以它非常灵活：

Private Sub TextBox1_Exit(ByVal Cancel As MSForms.ReturnBoolean)
    If TextBox1.Text <> "" Then
        If IsDate(TextBox1.Text) Then
            TextBox1.Text = Format(TextBox1.Text, "mm/dd/yyyy")
        Else
            MsgBox "Please enter a valid date!"
            Cancel = True
        End If
    End If
End Sub

但是，我认为 Sid 开发的是一种更好的方法 - 一个完整的日期选择器控件。

score 2 · Accepted Answer

只是为了好玩，我接受了 Siddharth 关于单独文本框的建议并做了组合框。如果有人感兴趣，可以添加一个用户表单，其中包含三个名为 cboDay、cboMonth 和 cboYear 的组合框，并将它们从左到右排列。然后将下面的代码粘贴到用户窗体的代码模块中。所需的组合框属性在 UserFormInitialization 中设置，因此不需要额外的准备。

棘手的部分是更改由于年份或月份的变化而变得无效的日期。此代码只是在发生这种情况时将其重置为 01 并突出显示 cboDay。

我已经有一段时间没有编写过这样的代码了。希望有一天它会引起某人的兴趣。如果不是，那很有趣！

Dim Initializing As Boolean

Private Sub UserForm_Initialize()
Dim i As Long
Dim ctl As MSForms.Control
Dim cbo As MSForms.ComboBox

Initializing = True
With Me
    With .cboMonth
        '        .AddItem "month"
        For i = 1 To 12
            .AddItem Format(i, "00")
        Next i
        .Tag = "DateControl"
    End With
    With .cboDay
        '        .AddItem "day"
        For i = 1 To 31
            .AddItem Format(i, "00")
        Next i
        .Tag = "DateControl"
    End With
    With .cboYear
        '        .AddItem "year"
        For i = Year(Now()) To Year(Now()) + 12
            .AddItem i
        Next i
        .Tag = "DateControl"
    End With
    DoEvents
    For Each ctl In Me.Controls
        If ctl.Tag = "DateControl" Then
            Set cbo = ctl
            With cbo
                .ListIndex = 0
                .MatchRequired = True
                .MatchEntry = fmMatchEntryComplete
                .Style = fmStyleDropDownList
            End With
        End If
    Next ctl
End With
Initializing = False
End Sub

Private Sub cboDay_Change()
If Not Initializing Then
    If Not IsValidDate Then
        ResetMonth
    End If
End If
End Sub

Private Sub cboMonth_Change()
If Not Initializing Then
    ResetDayList
    If Not IsValidDate Then
        ResetMonth
    End If
End If
End Sub

Private Sub cboYear_Change()
If Not Initializing Then
    ResetDayList
    If Not IsValidDate Then
        ResetMonth
    End If
End If
End Sub

Function IsValidDate() As Boolean
With Me
    IsValidDate = IsDate(.cboMonth & "/" & .cboDay & "/" & .cboYear)
End With
End Function
Sub ResetDayList()
Dim i As Long
Dim StartDay As String

With Me.cboDay
    StartDay = .Text
    For i = 31 To 29 Step -1
        On Error Resume Next
        .RemoveItem i - 1
        On Error GoTo 0
    Next i
    For i = 29 To 31
        If IsDate(Me.cboMonth & "/" & i & "/" & Me.cboYear) Then
            .AddItem Format(i, "0")
        End If
    Next i
    On Error Resume Next
    .Text = StartDay
    If Err.Number <> 0 Then
        .SetFocus
        .ListIndex = 0
    End If
End With
End Sub

Sub ResetMonth()
Me.cboDay.ListIndex = 0
End Sub

score 1 · Accepted Answer

虽然我同意下面的答案中提到的内容，但这表明这对于用户表单来说是一个非常糟糕的设计，除非包含大量的错误检查......

为了完成您需要做的事情，只需对代码进行最少的更改，有两种方法。

对文本框使用KeyUp()事件而不是 Change 事件。这是一个例子：

Private Sub TextBox2_KeyUp(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)

    Dim TextStr As String
    TextStr = TextBox2.Text

    If KeyCode <> 8 Then ' i.e. not a backspace

        If (Len(TextStr) = 2 Or Len(TextStr) = 5) Then
            TextStr = TextStr & "/"
        End If

    End If
    TextBox2.Text = TextStr
End Sub

或者，如果您需要使用Change()事件，请使用以下代码。这会改变行为，因此用户不断输入数字，如
```
12072003
```

而他输入的结果显示为

    12/07/2003

但“/”字符仅在输入 DD 的第一个字符即 0 的 07 时出现。不理想，但仍会处理退格。

    Private Sub TextBox1_Change()
        Dim TextStr As String

        TextStr = TextBox1.Text

        If (Len(TextStr) = 3 And Mid(TextStr, 3, 1) <> "/") Then
            TextStr = Left(TextStr, 2) & "/" & Right(TextStr, 1)
        ElseIf (Len(TextStr) = 6 And Mid(TextStr, 6, 1) <> "/") Then
            TextStr = Left(TextStr, 5) & "/" & Right(TextStr, 1)
        End If

        TextBox1.Text = TextStr
    End Sub

score 1 · Accepted Answer

Private Sub txtBoxBDayHim_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)
If KeyAscii >= 48 And KeyAscii <= 57 Or KeyAscii = 8 Then 'only numbers and backspace
    If KeyAscii = 8 Then 'if backspace, ignores + "/"
    Else
        If txtBoxBDayHim.TextLength = 10 Then 'limit textbox to 10 characters
        KeyAscii = 0
        Else
            If txtBoxBDayHim.TextLength = 2 Or txtBoxBDayHim.TextLength = 5 Then 'adds / automatically
            txtBoxBDayHim.Text = txtBoxBDayHim.Text + "/"
            End If
        End If
    End If
Else
KeyAscii = 0
End If
End Sub

这对我有用。:)

你的代码对我帮助很大。谢谢！

我是巴西人，我的英语很差，如有错误请见谅。

excel - 在 VBA 的文本框中格式化 MM/DD/YYYY 日期

9 回答 9

Related

Reference