VBA Input Date Automatically in Excel

Question

Could assist on this? For Example, column A is date today which will fill in automatically, if the person fill in due date at column B. However, if the due date is more than 3 months of the date today, it will restrict the person to fill in the due date. The person only can fill in the due date if the due date is equal or less than 3 months as per date today. Could help me check if how to edit the VBA code:

[enter image description here]

Please provide enough code so others can better understand or reproduce the problem. — Community, Jan 26 '22 at 13:20

score 1 · Answer 1 · answered Jan 16 '22 at 01:42

I'm not certain if you meant 3 months after today or before today, but if you have =IF(ISBLANK(@B:B),"",TODAY()) as the formula in column A, insert this into the worksheet object code.

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

VBA Input Date Automatically in Excel

1 Answers1