VBA 在 Excel 中自动输入日期答案

【问题标题】：VBA Input Date Automatically in ExcelVBA 在 Excel 中自动输入日期
【发布时间】：2022-01-16 00:19:10
【问题描述】：

可以提供帮助吗？例如，A 列是今天的日期，如果此人在 B 列填写截止日期，它将自动填写。但是，如果截止日期比今天的日期超过3个月，它将限制该人填写截止日期。如果截止日期等于或小于今天的 3 个月，则此人只能填写截止日期。可以帮我检查一下如何编辑 VBA 代码：

[在此处输入图片描述]

【问题讨论】：

请提供足够的代码，以便其他人更好地理解或重现问题。

标签： excel vba datetime input locked

【解决方案1】：

我不确定您的意思是今天之后的 3 个月还是今天之前，但如果您在 A 列中有 =IF(ISBLANK(@B:B),"",TODAY()) 作为公式，请将其插入到工作表目标代码中。

Option Explicit
#Const ShowErrMsg = True 'Change to False if you want the invalid insertion to fail silently and not send the user an error message.
Private Sub Worksheet_Change(ByVal Target As Range)
Const InvalidDateErrorNumber = 1234 + vbObjectError 'Always add vbObjectError to custom error numbers inside a class
Dim cel As Excel.Range, ChangedDueDateRange As Excel.Range
Dim ErrMsg As String
On Error GoTo EH_InvalidDueDate
Set ChangedDueDateRange = Excel.Intersect(Target, Me.Range("B:B")) 'You might change a large range of cells, but we're only concerned with those in Column B
If Not ChangedDueDateRange Is Nothing Then
    For Each cel In ChangedDueDateRange
CellCleared: 'Return here after clearing the cell.
        If Not cel.Value = vbEmpty Then
            If CDate(cel.Value) > VBA.DateTime.DateAdd("m", 3, VBA.Date) Then 'CDate in case you end up pasting a number that could be equivalent to a date.
                Err.Raise InvalidDateErrorNumber, Source:=Me.Name, Description:="Invalid Date"
#If ShowErrMsg Then 'This sort of #if is a compiler directive that basically toggles code on and off without evaluating a condition at runtime.
                VBA.Interaction.MsgBox ErrMsg, Buttons:=VbMsgBoxStyle.vbExclamation, Title:="Invalid Date"
#End If
            End If
        End If
    Next cel
End If
Exit Sub
EH_InvalidDueDate:
ErrMsg = cel.Address(RowAbsolute:=False, Columnabsolute:=False)
Select Case Err.Number
    Case 13 '13 is type mismatch, in case the value inserted is not even a date.
        ErrMsg = "Insert a date up to 3 months after today into cell " & ErrMsg & vbNewLine & ". You entered a " & TypeName(cel.Value)
    Case InvalidDateErrorNumber
        ErrMsg = "Date inserted in cell " & ErrMsg & " is more than 3 months after today."
    Case Else
        Err.Raise Err.Number, Err.Source, Err.Description, Err.HelpFile, Err.HelpContext
End Select
With Application 'Temporarily disable events to avoid triggering an infinite loop of change events.
    .EnableEvents = False
    cel.ClearContents
    .EnableEvents = True
End With
Resume CellCleared
End Sub

【讨论】：