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