A column in a sheet that I am working for, accepts date values. What I would like to do is to permit as valid user entries only dates that are equal or come after the current date. So, in a intent of mine a came up with the following:
Dim StageDate As date
If Target.Column = 11 Then
StageDate = InputBox("Enter a Valid Date")
If StageDate <= Date Then Target.value = StageDate
Else: MsgBox("Please enter a valid date")
End If
End If
This doesn't work very nice. Could I ask for your proposals? Thank so much!
May be a bit much. I always like to test that a proper date has been entered first. 1<date will return True as 1 is 01/01/1900 (or is it 31/12/1899)
Public Sub Test()
Dim dateRange As Range
Set dateRange = ThisWorkbook.Worksheets("Sheet1").Range("A2")
If IsDate(dateRange) Then
If dateRange < Date Then
MsgBox "Invalid date", vbInformation + vbOKOnly
dateRange = Null
End If
Else
dateRange = Null
End If
End Sub
'Check that the value entered is a date.
'Returns TRUE/FALSE.
'http://regexlib.com/DisplayPatterns.aspx?cattabindex=4&categoryId=5
'Description:
'DD.MM.YY or DD.MM.YYYY separator could be on choice '.' '/' or '-' leap years compatible, 00 is treated as year 2000.
'Matches
' 29.2.04 | 29/02-2004 | 3.4.05
'Non -Matches
' 29.2.03 | 2902.2004 | 12.31.1975
'Author: Dany Lauener
Public Function IsDate(ADate As Range) As Boolean
Dim RegX As Object
Set RegX = CreateObject("VBScript.RegExp")
RegX.Pattern = "^(((0?[1-9]|[12]\d|3[01])[\.\-\/](0?[13578]|1[02])" & _
"[\.\-\/]((1[6-9]|[2-9]\d)?\d{2}))|((0?[1-9]|[12]\d|30)" & _
"[\.\-\/](0?[13456789]|1[012])[\.\-\/]((1[6-9]|[2-9]\d)?\d{2}))" & _
"|((0?[1-9]|1\d|2[0-8])[\.\-\/]0?2[\.\-\/]((1[6-9]|[2-9]\d)?\d{2}))|" & _
"(29[\.\-\/]0?2[\.\-\/]((1[6-9]|[2-9]\d)?(0[48]|[2468][048]|[13579][26])|" & _
"((16|[2468][048]|[3579][26])00)|00)))$"
IsDate = RegX.Test(ADate)
End Function
You could shorten the `IsDate` function to something like:
Public Function IsDate(ADate As Range) As Boolean
Dim tmpDate As Date
On Error Resume Next
tmpDate = DateValue(ADate)
IsDate = (Err.Number = 0)
On Error GoTo 0
End Function
What you are looking for is DateValue();
https://support.office.com/en-us/article/DATEVALUE-function-df8b07d4-7761-4a93-bc33-b7471bbff252
With this you can compare Dates:
DateValue(TextBoxStartDate.Text) < DateValue(TextBoxEndDate.Text)
Related
I am trying to develop VBA code that yields the accurate number of months and remaining days between two dates.
The test dates to be used are the following:
Date1: 04/19/1995
Date2: 12/26/22
The correct answer per: https://www.calculator.net/date-calculator.html is: 332 months 7 days
The correct answer generated per my VBA code below is: 332 months 3 days.
Can anyone shed some light as to why this is the case?
Private Sub CommandButton7_Click()
' Calculate the difference between two dates in months and remaining days
Dim startDate As Date
Dim endDate As Date
Dim months As Long
Dim days As Long
startDate = Application.InputBox("Enter a date:", "Date Input 1", Date, Type:=2)
endDate = Application.InputBox("Enter another date:", "Date Input 2", Date, Type:=2)
months = Abs(DateDiff("m", startDate, endDate))
days = Abs(DateDiff("d", startDate, endDate)) Mod 30
MsgBox "The difference between the two dates is: " & months & " months and " & days & " days."
End Sub
Yes. The following line in your code -
days = Abs(DateDiff("d", startDate, endDate)) Mod 30
assumes that all months have 30 days. They do not!
It is not that simple because of the varying count of days of the months. You have to use DateAdd to obtain the correct month count.
This function does it right:
' Returns the difference in full months from DateOfBirth to current date,
' optionally to another date.
' Returns by reference the difference in days.
' Returns zero if AnotherDate is earlier than DateOfBirth.
'
' Calculates correctly for:
' leap Months
' dates of 29. February
' date/time values with embedded time values
' any date/time value of data type Date
'
' DateAdd() is, when adding a count of months to dates of 31th (29th),
' used for check for month end as it correctly returns the 30th (28th)
' when the resulting month has 30 or less days.
'
' 2015-11-24. Gustav Brock, Cactus Data ApS, CPH.
'
Public Function AgeMonthsDays( _
ByVal DateOfBirth As Date, _
Optional ByVal AnotherDate As Variant, _
Optional ByRef Days As Integer) _
As Long
Dim ThisDate As Date
Dim Months As Long
If IsDateExt(AnotherDate) Then
ThisDate = CDate(AnotherDate)
Else
ThisDate = Date
End If
' Find difference in calendar Months.
Months = DateDiff("m", DateOfBirth, ThisDate)
If Months < 0 Then
Months = 0
Else
If Months > 0 Then
' Decrease by 1 if current date is earlier than birthday of current year
' using DateDiff to ignore a time portion of DateOfBirth.
If DateDiff("d", ThisDate, DateAdd("m", Months, DateOfBirth)) > 0 Then
Months = Months - 1
End If
End If
' Find difference in days.
Days = DateDiff("d", DateAdd("m", Months, DateOfBirth), ThisDate)
End If
AgeMonthsDays = Months
End Function
Example (in the immidiate pane):
Days% = 0
? AgeMonthsDays(#04/19/1995#, #12/26/2022#, Days%), Days%
332 7
It is from my library at GitHub: VBA.Date.
Date Difference in Months and Days
The Button Code
Private Sub CommandButton7_Click()
DateDifference
End Sub
The Main Method
Sub DateDifference()
' Calculates the difference between two dates in months and days.
' Define constants.
Const PROC_TITLE As String = "Date Difference"
Dim Prompts(): Prompts = VBA.Array("Enter a date:", "Enter another date:")
Dim Titles(): Titles = VBA.Array("Date Input 1", "Date Input 2")
' Get the input using the 'GetInputDate' function.
Dim InputValue As Variant
Dim Dates(0 To 1) As Date
Dim d As Long
For d = 0 To 1
InputValue = GetInputDate(Prompts(d), Titles(d))
If IsEmpty(InputValue) Then Exit Sub
Dates(d) = CDate(InputValue)
Next d
' Determine the Start and End date ('Start <= End').
Dim StartDate As Date, EndDate As Date
If Dates(0) < Dates(1) Then
StartDate = Dates(0)
EndDate = Dates(1)
Else
StartDate = Dates(1)
EndDate = Dates(0)
End If
' Calculate the difference.
Dim Months As Long: Months = DateDiff("m", StartDate, EndDate)
Dim MonthDate As Date: MonthDate = DateAdd("m", Months, StartDate)
Dim Days As Long: Days = DateDiff("d", MonthDate, EndDate)
' Inform.
Dim Msg As String: Msg = "The difference between the two dates is " _
& IIf(Months = 1, "one month", Months & " months") & " and " _
& IIf(Days = 1, "one day", Days & " days") & "."
MsgBox Msg, vbInformation, PROC_TITLE
End Sub
A Helper Function
Function GetInputDate( _
ByVal Prompt As String, _
ByVal Title As String) _
As Variant ' a date or 'Empty'
Const PROC_TITLE As String = "Get Input Date"
Dim InputValue As Variant, MsgAnswer As Long, Msg As String
Do
InputValue = Application.InputBox(Prompt, Title, Date, , , , , 2)
If VarType(InputValue) = vbBoolean Then
MsgBox "Canceled.", vbExclamation, PROC_TITLE
Exit Function
End If
If IsDate(InputValue) Then GetInputDate = InputValue: Exit Function
Msg = "The string """ & InputValue & """ can't be converted " _
& "to a date. Do you want to try again?"
MsgAnswer = MsgBox(Msg, vbYesNo + vbQuestion, PROC_TITLE)
If MsgAnswer = vbNo Then Exit Function
Loop
End Function
I need to round time to the nearest quarter hour in a word document. I am not very good at coding.
After a fair bit of searching I have found some vba code but it doesn't quite work. The code is:
Sub Time()
Dim num() As String
Dim tod() As String
Dim temp As String
num = Split(Time, ":")
tod = Split(num(2), " ")
If Val(num(1)) < 15 Then
temp = "00"
ElseIf Val(num(1)) < 30 Then
temp = "15"
ElseIf Val(num(1)) < 45 Then
temp = "30"
ElseIf Val(num(1)) < 60 Then
temp = "45"
End If
gettime = num(0) + ":" + temp + ":00 " + tod(1)
End Function
End Sub
When I try to run it I get a message:
"Compile Error: Expected function or variable"
and "Time" on the fifth line of the code is highlighted which I think is where the program stops running.
The rest of the code in the form is as follows:
This module doesn't affect the time rounding issue but I am including it so as not to leave anything out.
Option Explicit
Sub ClusterCheck()
Dim i As Integer, k As Integer, iCluster As Integer, bResult As Boolean
Dim sFieldNameNo As String, sName As String
On Error Resume Next ' If the first formfield is a checkbox, this will bypass the error that Word returns
sName = Selection.FormFields(1).Name ' Get the name of the formfield
bResult = ActiveDocument.FormFields(sName).CheckBox.Value ' Get the result of the current formfield
sFieldNameNo = Number(sName) ' Get generic number
sName = Left(sName, Len(sName) - Len(sFieldNameNo)) ' Get generic name
' Determine how many fields are within the cluster group
iCluster = 1
Do Until ActiveDocument.Bookmarks.Exists(sName & iCluster) = False
iCluster = iCluster + 1
Loop
iCluster = iCluster - 1
' If the check field is true, turn all of the other check fields to false
Application.ScreenUpdating = False
If bResult = True Then
For k = 1 To iCluster
If k <> sFieldNameNo Then ActiveDocument.FormFields(sName & k).Result = False
Next
End If
Application.ScreenUpdating = True
End Sub
This is the Number module:
Option Explicit
Function Number(ByVal sNumber As String) As String
' This module finds the form fields number within the field name
' Loops through the field name until it only has the number
Do Until IsNumeric(sNumber) = True Or sNumber = ""
sNumber = Right(sNumber, Len(sNumber) - 1)
Loop
Number = sNumber
End Function
This is the protection module:
Option Explicit
Sub Protect()
ActiveDocument.Protect Password:="wup13", NoReset:=True, Type:=wdAllowOnlyFormFields
End Sub
Sub Unprotect()
ActiveDocument.Unprotect Password:="wup13"
End Sub
This is the code that activates on opening and closing the document:
Option Explicit
Sub Document_Open()
' Zooms to page width, turns on Hidden Text, and turns off ShowAll and Table Gridlines
With ActiveWindow.View
.Zoom.PageFit = wdPageFitBestFit
.ShowHiddenText = True
.TableGridlines = False
.ShowAll = False
End With
Options.UpdateFieldsAtPrint = False
End Sub
Sub Document_Close()
' Turn on ShowAll and Table Gridlines
With ActiveWindow.View
.ShowAll = True
.TableGridlines = True
End With
Options.UpdateFieldsAtPrint = True
End Sub
That's all the code in the form. I am not great at VBA but am hoping I can solve this issue (with a little help).
DETAILS OF EXTRA DUTY FORM
Persons details
Family name:
Given name(s):
Level:
No.:
Location:
Cost Centre Code:
Time worked
Were any days of the extra duty performed on a designated public/show holiday? Yes 0 No 0
If yes enter holiday date/details:
Time commenced: [Text Form Field]
Date:
Time ceased: [Text Form Field]
Date:
Total Overtime claimed:
Are you a shift worker? Yes 0 No 0
Details of extra duty performed:
Vehicle details
Car: Yes 0 No 0
Motorcycle: Yes 0 No 0
Registration no.:
Fleet no.:
Stationary vehicle hours:
Yes 0 No 0 (only use for stationary duties)
Vehicle odometer start:
Odometer finish:
Total kms:
Client’s details
Company/Organisation name:
Phone no.:
Contact name:
Job no.:
Payment for special services
Was payment received in advance? Yes 0 No 0
If Yes– Amount:
Receipt no.:
Date:
If No– Amount:
Invoice no.:
Date:
I, , certify the above information to be true
(Signature) (Date)
Manager certification (Checked with roster and certified correct)
(Signature) (Date)
The code from vbforums gives me a subscript out of range error when used as recommended.
In the VBA IDE you can get explanations of what keywords do by placing the cursor on a keyword and pressing F1. This will bring up the MS help page for that particular keyword.
In the OP code the main procedure is 'Time'. This will cause problems for VBA because this is the same as the Time keyword so we would effectively be saying
time(time)
and VBA will stop with an error because the second use of time will be interpreted as the sub time and not the VBA time function so you will get the error message 'Argument not optional'.
The code below will provide what the OP has requested.
Option Explicit
Sub test_gettime()
Dim myTime As String
myTime = Now()
Debug.Print myTime
Debug.Print Format(myTime, "hh:mm:ss")
Debug.Print gettime(Format(myTime, "hh:mm:ss"))
' without the format statement we should also get the date
myTime = Now()
Debug.Print
Debug.Print myTime
Debug.Print gettime(myTime)
End Sub
Public Function gettime(this_time As String) As String
Dim myTimeArray() As String
Dim myQuarterHour As String
myTimeArray = Split(this_time, ":")
' Note that myTimeArray has not been converted to numbers
' Comparison of strings works by comparing the ascii values of each character
' in turn until the requested logic is satisfied
Select Case myTimeArray(1)
Case Is < "15"
myQuarterHour = "00"
Case Is < "30"
myQuarterHour = "15"
Case Is < "45"
myQuarterHour = "30"
Case Is < "60"
myQuarterHour = "45"
Case Else
Debug.Print "More than 60 minutes in the hour??"
End Select
gettime = myTimeArray(0) + ":" + myQuarterHour + ":00 "
End Function
The following is my code:
Option Explicit
Public Function StudyDuration(ByVal Start As Date, Format As String, Optional ByVal Graduation As Date, Optional ByVal Expected As Date) As String
Dim TillGraduation As Integer
StudyDuration = Graduation Or Expected - Start
TillGraduation = DateDiff("ymd", Date, Expected)
If Graduation = 0 And Expected = 0 Then Graduation = Date
Range("B1").Value = Start
Range("B2").Value = Graduation
Range("B3").Value = Expected
Range("B4").Value = StudyDuration
Range("B5").Value = TillGraduation
If Graduation = 0 And Expected > Start Then
StudyDuration = Expected - Start And TillGraduation = DateDiff("ymd", Date, Expected)
MsgBox ("Study Length" & " is" & Range("B4").Value & vbNewLine & Range("B5") & "till Graduate")
End If
End Function
However, the cell B1 keeps showing the date 1/7/1900. Can anyone tell me how should I correct it?
Thanks a lot!
I believe that functions are not allowed to modify cell values. A function is only supposed to return a value that will set the value for the cell that is called from.
If you want to modify cell values, then you should look at using a Sub instead.
BTW, your function makes no use of the Format parameter.
I am relatively new to VBA, and I need some help on a code I have been writing. Currently, it looks like this:
Sub RoundedRectangle1_Click()
Selection.NumberFormat = "dd mmm yy"
Range("H2").ClearContents
Dim Date1 As ValueChange
Range("H2").Value = InputBox("Enter the first date (Monday) of the week you wish to view, in the format DD/MM")
End Sub
As you can see, I have a pop-up box for the user to manually enter the date, but for some reason, once this is entered it keeps providing an answer in the US format, for instance if I type in 04/12, this will appear as "12 Apr 16", rather than "04 Dec 16"
According to my tests, InputBox returns a string. What I would do, is write the following function (just demo, no error handling in this code):
Private Function ParseDate(sInput As String) As Date
Dim sTmp() As String
sTmp = Split(sInput, "/")
ParseDate = DateTime.DateSerial(2016, sTmp(1), sTmp(0))
End Function
and then simply call it like this:
Dim sResult As String
sResult = InputBox("Enter the first date (Monday) of the week you wish to view, in the format DD/MM")
Range("H2").Value = ParseDate(sResult)
This macro, which asks for the date to be printed at the head of an attendance register works for dd/mm/yy or dd/mm in the 21st century. Could easily be adapted to include 20th cent
Sub Print_Register()
'
' Print_Register Macro
Dim MeetingDate, Answer
Sheets("Register").Select
Range("A1").Select
GetDate:
MeetingDate = DateValue(InputBox("Enter the date of the meeting." & Chr(13) & _
"Note Format" & Chr(13) & "Format DD/MM/YY or DD/MM", "Meeting Date", , 10000, 10000))
If MeetingDate = "" Then GoTo TheEnd
If MeetingDate < 36526 Then MeetingDate = MeetingDate + 36525 'If no yy add year 2000
Range("Current_Meeting_Date") = MeetingDate
Answer = MsgBox("Date OK?", 3)
If Answer = 2 Then GoTo TheEnd
If Answer = 7 Then GoTo GetDate
ExecuteExcel4Macro "PRINT(1,,,1,,,,,,,,2,,,TRUE,,FALSE)"
TheEnd:
End Sub
In Excel using VBA, I need to set a variable to equal a list of all the dates between a start and end date (similar to equaling a range containing multiple values). The catch is only the start and end date are in a range, non of the values in between.
In SQL Server I've used the Sys.Columns table to generate a list of dates between two dates that are not actually stored on that table. Is there a way to do something similar here without having each date between the start and end date written somewhere? I googled for a couple hours and didn't find anything on how to do this.
What I'm attempting to do is have a variable I can do a For Each loop on. So for each date I will check if it exists in another worksheet, if it does nothing will happen, if it does not it will be added.
I've tried:
Dim DatesInSettings As Date
DatesInSettings = StartDate To EndDate
For Each Date In DatesInSettings
'Insert commands here
Next DatesInSetting
But that clearly isn't the answer. Help?
This searches Sheet2 for dates between the start date and end dates on Sheet1 - in cells A1 and B1:
Sub RunDates()
Dim StartDate As Date
Dim EndDate As Date
Dim i As Date
StartDate = Sheet1.Range("A1")
EndDate = Sheet1.Range("B1")
For i = StartDate To EndDate
If WorksheetFunction.CountIf(Sheet2.Range("A1:A5"), i) > 0 Then
Debug.Print i; "- date found"
Else
Debug.Print i; "- date not found"
End If
Next i
End Sub
The following subroutine calls a dictionary that will store all the dates between two given endpoints. Then it uses a simple existence comparison to check if the dates on your list is inside the dictionary's items. If it's not, it's going to print them out as not in the list.
Modify accordingly to suit your needs. ;)
CODE:
Sub GetListOfDates()
Dim StartDate As Date, EndDate As Date
Dim DictOfDates As Object, DateToCheck As Variant, ListOfDates As Variant
Dim Iter As Long
Set DictOfDates = CreateObject("Scripting.Dictionary")
StartDate = "12/31/2013"
EndDate = "01/15/2014"
For Iter = StartDate + 1 To EndDate - 1
With DictOfDates
If Not .Exists(Iter) Then
.Add Iter, Empty
End If
End With
Next Iter
'--Print them somewhere.
'Range("A1").Resize(DictOfDates.Count, 1).Value = Application.Transpose(DictOfDates.Keys)
ListOfDates = Range("B1:B15").Value
For Each DateToCheck In ListOfDates
If Not DictOfDates.Exists(DateToCheck) Then
Debug.Print Str(DateToCheck) + " is not in the list!" '--Or whatever action you want.
End If
Next DateToCheck
Set DictOfDates = Nothing
End Sub
Let us know if this helps. :)
I solved it with a vector.
I hope it helps
Sub Dates_Vector()
Public Dates() As Date
ReDim Dates(End_Dat - Start_Date)
For x = 0 To End_Dat - Start_Date
Dates(x) = Dat_Ini + x
Next x
For Each Date In Dates
'Insert commands here
Next Date
End Sub