PDA

View Full Version : [SOLVED] How to restrict users between two dates using VBA



Jumak18
01-05-2019, 12:10 AM
Hello everybody

I'm using data validation to restrict user between two dates, it is working.
but If I want to use vba what is the code?

I have target range "G4:H1000" where the user can enter the dates ( From:TO)
restricted dates is stored in cell (G1) as start date and in cell (H1) as End date
also date format dd/mm/yyyy or dd/mm/yy

if user enters date out of range
MsgBox "Invalid date is entered"
Target.ClearContents

thank you

Paul_Hossler
01-05-2019, 09:33 AM
23514

Probably something like this in the worksheet code module (not a standard module)




Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
Dim rCell As Range, rDates As Range

If Intersect(Target, Range("G4:H1000")) Is Nothing Then Exit Sub ' didn't change in correct area

Set rDates = Nothing
On Error Resume Next
Set rDates = Target.SpecialCells(xlCellTypeConstants, xlNumbers) ' Dates are really numbers
On Error GoTo 0

If rDates Is Nothing Then Exit Sub ' no numbers

For Each rCell In rDates.Cells ' do one at a time since multiple cells can be entered at once
If IsDate(rCell.Value) Then
If rCell.Value < Range("G1") Or rCell.Value > Range("H1") Then
MsgBox "Invalid Date Entered -- " & rCell.Value & " (" & rCell.Address & ")"
Application.EnableEvents = False ' avoid calling Worksheet_Change for THIS change
rCell.ClearContents
Application.EnableEvents = True
rCell.Select
End If
End If
Next
End Sub

Jumak18
01-05-2019, 10:11 AM
thank you very much for reply
it is working

but I also need to prevent user not to enter text or date by mistake like this 05//02/2019 (two slash)
sometimes they will enter like this 113/02/2019 date 113, such entries give invalid data when subtract end date and start date
So they should be restricted to isdate

if possible

Paul_Hossler
01-05-2019, 12:19 PM
Try this




Option Explicit


Private Sub Worksheet_Change(ByVal Target As Range)
Dim rCell As Range, rDates As Range

If Intersect(Target, Range("G4:H1000")) Is Nothing Then Exit Sub ' didn't change in correct area

Set rDates = Intersect(Target, Range("G4:H1000"))


For Each rCell In rDates.Cells ' do one at a time since multiple cells can be entered at once
If Len(rCell.Value) = 0 Then GoTo NextCell

If IsDate(rCell.Value) Then
If rCell.Value < Range("G1") Or rCell.Value > Range("H1") Then
MsgBox "Invalid Date Entered -- " & rCell.Value & " (" & rCell.Address & ")"
Application.EnableEvents = False ' avoid calling Worksheet_Change for THIS change
rCell.ClearContents
Application.EnableEvents = True
rCell.Select
End If

Else
MsgBox "Not a Date -- " & rCell.Value & " (" & rCell.Address & ")"
Application.EnableEvents = False ' avoid calling Worksheet_Change for THIS change
rCell.ClearContents
Application.EnableEvents = True
rCell.Select
End If
NextCell:
Next
End Sub

Jumak18
01-05-2019, 12:52 PM
Thank you very much Paul
it is working 100% :clap:

regards

:hi: :hi: :thumb

Paul_Hossler
01-05-2019, 03:01 PM
Good

You can mark it SOLVED by using [Tread Tools] above your first post

Jumak18
01-06-2019, 10:29 AM
Good

You can mark it SOLVED by using [Tread Tools] above your first post
done