Code Snippets


FirstOfMonth

This function calculates the first day of a month, given a date. If no date is passed in, the function uses the current date.

Public Function FirstOfMonth(Optional dteDate As Date) As Date 

If CLng(dteDate) = 0 Then
dteDate = Date
End If

FirstOfMonth = DateSerial(Year(dteDate), Month(dteDate), 1)
End Function

LastOfMonth

This function calculates the last day of a month, given a date. If no date is passed in, the function uses the current date.

Public Function LastOfMonth(Optional dteDate As Date) As Date 

If CLng(dteDate) = 0 Then
dteDate = Date
End If

' Find the first day of the next month, then subtract one day.
LastOfMonth = DateSerial(Year(dteDate), Month(dteDate) + 1, 1) - 1
End Function

IsWorkday

This function determines whether a date falls on a weekday. If no date passed in, use today's date.

Public Function IsWorkday(Optional dteDate As Date) As Boolean 

If CLng(dteDate) = 0 Then
dteDate = Date
End If

Select Case Weekday(dteDate)
Case vbMonday To vbFriday
IsWorkday = True
Case Else
IsWorkday = False
End Select
End Function

This Pauses for 5 seconds

Nexttime = Now() + TimeValue("00:00:05") 
Application.Wait Nexttime


The following procedure finds the anniversary of a given date; that is, the next date on which it occurs.
If the anniversary has already occurred this year, the procedure returns the date of the anniversary in the next year.
This function finds the next anniversary of a date. If the date has already passed for this year, it returns the date on which the anniversary occurs in the following year.

Function Anniversary(dteDate As Date) As Date 
Dim dteThisYear As Date

' Find corresponding date this year.
dteThisYear = DateSerial(Year(Date), Month(dteDate), Day(dteDate))
' Determine whether it's already passed.
If dteThisYear < Date Then
Anniversary = DateAdd("yyyy", 1, dteThisYear)
Else
Anniversary = dteThisYear
End If
End Function


The procedure determines the last day of the last year by using the DateSerial function, and then subtracts that date from the date that was passed in to the procedure.
This function takes a date as an argument and returns the day number for that year. If the dteDate argument is omitted, the function uses the current date.

Function DayNumberInYear(Optional dteDate As Date) As Long 

' If dteDate argument has not been passed, dteDate is
' initialized to 0 (or December 30, 1899, the date
' equivalent of 0).
If CLng(dteDate) = 0 Then
' Use today's date.
dteDate = Date
End If

' Calculate the number of days that have passed since
' December 31 of the previous year.
DayOfYear = Abs(DateDiff("d", dteDate, _
DateSerial(Year(dteDate) - 1, 12, 31)))
End Function

Using the DateDiff function to determine the number of years between today and a birthdate doesn't always give a valid result because the DateDiff function rounds to the next year.
If a person's birthday hasn't yet occurred, using the DateDiff function will make the person one year older than he or she actually is.
To remedy this situation, the procedure checks to see whether the birthday has already occurred this year, and if it hasn't, it subtracts 1 to return the correct age.

Function CalcAge(dteBirthdate As Date) As Long 

Dim lngAge As Long

' Make sure passed-in value is a date.
If Not IsDate(dteBirthdate) Then
dteBirthdate = Date
End If

' Make sure birthdate is not in the future.
' If it is, use today's date.
If dteBirthdate > Date Then
dteBirthdate = Date
End If

' Calculate the difference in years between today and birthdate.
lngAge = DateDiff("yyyy", dteBirthdate, Date)
' If birthdate has not occurred this year, subtract 1 from age.
If DateSerial(Year(Date), Month(dteBirthdate), Day(dteBirthdate)) > Date Then
lngAge = lngAge - 1
End If
CalcAge = lngAge
End Function


Time Loop

Sub TimeLoop() 
   Dim AbortTime As Date
   
   AbortTime = Now + TimeValue("0:00:05") ' Wait for 5 seconds

   Do While (True)
'Code for one iteration goes here
      If (Now > AbortTime) Then
         Exit Do
      End If
   Loop
End Sub



© 2024 Better Solutions Limited. All Rights Reserved. © 2024 Better Solutions Limited TopPrev