日期和时间的 VBA 输入框，而不仅仅是时间

Question

我早些时候就这种格式提出了一个问题，我得到了一个非常有帮助的答案。 我要求放置一个输入框，在将值添加到单元格并获取此代码后询问时间 显式选项

Private Sub Worksheet_Change(ByVal Target As Range)

If Target.Cells.Count > 1 Then Exit Sub 'abort if more than one cell was changed

'only run the code if a cell in column A was changed
If Not Intersect(Target, Me.Columns("A")) Is Nothing Then
    'ask for time and write it 2 columns right of the target cell
    Target.Offset(ColumnOffset:=2).Value = AskForValidTime
End If
End Sub


Private Function AskForValidTime() As String
Dim IsValid As Boolean

Do Until IsValid
    Dim Result As Variant
    Result = Application.InputBox("Wat is de tijd dat het monster genomen is?" & vbNewLine & "Gebruik UU:MM" & vbNewLine & "Voorbeeld: 09:30", "Tijdnotatie")
    
    'test if time is a valid time with less than 24 hours and less than 60 minutes
    Dim SplitTime() As String
    SplitTime = Split(Result, ":")
    If UBound(SplitTime) = 1 Then
        If Val(SplitTime(0)) < 24 And Val(SplitTime(1)) < 60 Then
            IsValid = True
            AskForValidTime = Result
            Exit Do
        End If
    End If

    MsgBox "Een correcte tijdsnotatie is nodig om door te gaan. Klik op" & vbNewLine & "<Ok> om de tijd opnieuw in te vullen", vbOKOnly + vbExclamation, vbNullString
Loop
End Function

到目前为止，这段代码运行良好，现在我试图让它询问日期和时间并验证两者。到目前为止，它还没有解决，因为我输入为 DD-MM 的日期从输入框中输出为 MM-DD。这是我对上面代码的改编，希望有人能帮助我。

选项显式

Private Sub Worksheet_Change(ByVal Target As Range)

If Target.Cells.Count > 1 Then Exit Sub 'abort if more than one cell was changed

'only run the code if a cell in column A was changed
If Not Intersect(Target, Me.Columns("A")) Is Nothing Then
    'ask for time and write it 2 columns right of the target cell
    Target.Offset(ColumnOffset:=2).Value = AskForValidTime
End If
End Sub


Private Function AskForValidTime() As String
Dim IsValid As Boolean

Do Until IsValid
    Dim Result As Variant
    Result = Application.InputBox("Wat is de tijd dat het monster genomen is?" & vbNewLine & "Gebruik UU:MM" & vbNewLine & "Voorbeeld: 09:30", "Tijdnotatie")
    
    'test if time is a valid time with less than 24 hours and less than 60 minutes
    Dim SplitDatetime() As String
    Dim SplitTime() As String
    SplitDatetime = Split(Result)
    If UBound(SplitDatetime) = 1 Then
    SplitTime = Split(SplitDatetime(1), ":")
        If Val(SplitTime(0)) < 24 And Val(SplitTime(1)) < 60 And IsDate(SplitDatetime(0)) Then
            IsValid = True
            AskForValidTime = Result
            Exit Do
        End If
    End If

    MsgBox "Een correcte tijdsnotatie is nodig om door te gaan. Klik op" & vbNewLine & "<Ok> om de tijd opnieuw in te vullen", vbOKOnly + vbExclamation, vbNullString
Loop
End Function

Answer 1

我建议进行以下更改

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
    
    If Target.Cells.Count > 1 Then Exit Sub 'abort if more than one cell was changed
    
    'only run the code if a cell in column A was changed
    If Not Intersect(Target, Me.Columns("A")) Is Nothing Then
        Target.Offset(ColumnOffset:=2).NumberFormat = "DD-MM-YYYY hh:mm"
        Target.Offset(ColumnOffset:=2).Value = AskForValidDateTime
    End If
End Sub


Private Function AskForValidDateTime() As Date
    Dim IsValid As Boolean
    
    Do Until IsValid
        Dim Result As Variant
        Result = Application.InputBox("Wat is de tijd dat het monster genomen is?" & vbNewLine & "Gebruik UU:MM" & vbNewLine & "Voorbeeld: 09:30", "Tijdnotatie")
        
        
        Dim SplitDateTime() As String 'split date from time
        SplitDateTime = Split(Result, " ")
        If UBound(SplitDateTime) = 1 Then
            Dim SplitDate() As String
            'note the following code only works for dates entered in the format DD-MM-YYYY
            SplitDate = Split(SplitDateTime(0), "-")
            If UBound(SplitDate) = 2 Then
                Dim SplitTime() As String
                SplitTime = Split(SplitDateTime(1), ":")
                If UBound(SplitTime) = 1 Then
                    If Val(SplitTime(0)) < 24 And Val(SplitTime(1)) < 60 Then
                        IsValid = True
                        'note the following code only works for dates entered in the format DD-MM-YYYY
                        AskForValidDateTime = DateSerial(Val(SplitDate(2)), Val(SplitDate(1)), Val(SplitDate(0))) + TimeSerial(Val(SplitTime(0)), Val(SplitTime(1)), 0)
                        Exit Do
                    End If
                End If
            End If
        End If
        
        MsgBox "Een correcte tijdsnotatie is nodig om door te gaan. Klik op" & vbNewLine & "<Ok> om de tijd opnieuw in te vullen", vbOKOnly + vbExclamation, vbNullString
    Loop
End Function

Answer 2

我认为您需要一个这样的函数，它可以根据您的设置检查您的日期格式并返回正确日期的字符串。

Function DtFormatType(strDate As String) As String

Dim str1 As String
Dim str2 As String
Dim str3 As String


str1 = Left(strDate, InStr(strDate, "/") - 1)
str2 = Left(Mid(strDate, InStr(strDate, "/") + 1), InStr(Mid(strDate, InStr(strDate, "/") + 1), "/") - 1)
str3 = Mid(Mid(strDate, InStr(strDate, "/") + 1), InStr(Mid(strDate, InStr(strDate, "/") + 1), "/") + 1)

If Application.International(xlDateOrder) = 0 Then
    DtFormatType = str2 & "/" & str1 & "/" & str3
ElseIf Application.International(xlDateOrder) = 1 Then
    DtFormatType = str1 & "/" & str2 & "/" & str3
ElseIf Application.International(xlDateOrder) = 2 Then
    DtFormatType = str3 & "/" & str2 & "/" & str1
End If

End Function

然后您可以参数化分隔符。