Примеры работы с датами

Список функций
Определение первого/последнего дня текущего квартала
Определение первого/последнего дня месяца
Определение первого/последнего дня следующего месяца
Определение первого/последнего дня предыдущего месяца
Определение первого/последнего дня текущей недели
Опредение номера дня в году (2 января = 2, 3 февраля = 34)
Данная функция определяет рабочий день или нет
Возвращение последнего рабочего дня в текущем месяце
Функция определения полных лет со дня рождения
Вычисление разницы в годах между двумя датами
Определение високосности года

Определение первого дня текущего квартала

Function FirstOfQuarter(Optional dteDate As Date) As Date
If CLng(dteDate) = 0 Then
dteDate = Date
End If
FirstOfQuarter = DateSerial(Year(dteDate), Int((Month(dteDate) - 1) / 3) * 3 + 1, 1)
End Function

Определение последнего дня текущего квартала

Function LastOfQuarter(Optional dteDate As Date) As Date
If CLng(dteDate) = 0 Then
dteDate = Date
End If
LastOfQuarter = DateSerial(Year(Date), Int((Month(Date) - 1) / 3) * 3 + 4, 0)
End Function

Определение первого дня месяца

Function FirstOfMonth(Optional dteDate As Date) As Date
'если параметр dteDate = 0 то для вычисления берется текущая дата
If CLng(dteDate) = 0 Then
dteDate = Date
End If
FirstOfMonth = DateSerial(Year(dteDate), Month(dteDate), 1)
End Function

Определение последнего дня месяца

Function LastOfMonth(Optional dteDate As Date) As Date
'если параметр dteDate = 0 то для вычисления берется текущая дата
If CLng(dteDate) = 0 Then
dteDate = Date
End If
'Ищется первый день следующего месяца, и вычитается один день
LastOfMonth = DateSerial(Year(dteDate), Month(dteDate) + 1, 1) - 1
End Function

Определение первого дня следующего месяца

Function FirstOfNextMonth(Optional dteDate As Date) As Date
If CLng(dteDate) = 0 Then
dteDate = Date
End If
FirstOfNextMonth = DateSerial(Year(dteDate), Month(dteDate) + 1, 1)
End Function

Определение последнего дня следующего месяца

Function LastOfNextMonth(Optional dteDate As Date) As Date
If CLng(dteDate) = 0 Then
dteDate = Date
End If
LastOfNextMonth = DateSerial(Year(dteDate), Month(dteDate) + 2, 0)
End Function

Определение первого дня предыдущего месяца

Function FirstOfPreviousMonth(Optional dteDate As Date) As Date
If CLng(dteDate) = 0 Then
dteDate = Date
End If
FirstOfPreviousMonth = DateSerial(Year(dteDate), Month(dteDate) - 1, 1)
End Function

Определение последнего дня предыдущего месяца

Function LastOfPreviousMonth(Optional dteDate As Date) As Date
If CLng(dteDate) = 0 Then
dteDate = Date
End If
LastOfPreviousMonth = DateSerial(Year(dteDate), Month(dteDate), 0)
End Function

Определение первого дня текущей недели

Function StartOfWeek(D As Variant, Optional FirstWeekday As Integer) As Variant '
'Пример: MsgBox StartOfWeek(Date)
If IsMissing(FirstWeekday) Then 'Sunday is the assumed first day of week.
StartOfWeek = D - Weekday(D) + 1
Else
StartOfWeek = D - Weekday(D, FirstWeekday) + 1
End If
End Function

Определение последнего дня текущей недели

Function EndOfWeek(D As Variant, Optional FirstWeekday As Integer) As Variant
'Пример: MsgBox EndOfWeek(Date)
If IsMissing(FirstWeekday) Then 'Sunday is the assumed first day of week.
EndOfWeek = D - Weekday(D) + 7
Else
EndOfWeek = D - Weekday(D, FirstWeekday) + 7
End If
End Function

Опредение номера дня в году (2 января = 2, 3 февраля = 34)

Function DayOfYear(Optional dteDate As Date) As Long
If CLng(dteDate) = 0 Then
dteDate = Date
End If
DayOfYear = Abs(DateDiff("d", dteDate, DateSerial(Year(dteDate) - 1, 12, 31)))
End Function

Данная функция определяет: рабочий день или нет

Примечание: Дни с понедельника по пятницу считаются рабочими

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

Функция возвращает последний рабочий день в текущем месяце (Понедельник-Пятница)

Function LastBusDay(D As Variant) As Variant
'Пример: MsgBox LastBusDay(Date)
Dim D2 As Variant
If VarType(D) <> 7 Then
LastBusDay = Null
Else
D2 = DateSerial(Year(D), Month(D) + 1, 0)
Do While Weekday(D2) = 1 Or Weekday(D2) = 7
D2 = D2 - 1
Loop
LastBusDay = D2
End If
End Function

Функция определения полных лет со дня рождения

Function CalcAge(dteBirthdate As Date) As Long
'В качестве параметра dteBirthdate необходимо задать дату рождения
'Пример: MsgBox CalcAge("09/03/75")
Dim lngAge As Long
If Not IsDate(dteBirthdate) Then
dteBirthdate = Date
End If
'Проверить, чтобы в качестве входного параметра не была задана дата в будущем
If dteBirthdate > Date Then
dteBirthdate = Date
End If
'Подсчет разницы в годях между текущей датой и датой рождения
lngAge = DateDiff("yyyy", dteBirthdate, Date)
'Вычитается один год, если в этом году дня рождения еще не было
If DateSerial(Year(Date), Month(dteBirthdate), Day(dteBirthdate)) > Date Then
lngAge = lngAge - 1
End If
CalcAge = lngAge
End Function

Вычисление разницы в годах между двумя датами

Естественно, что значение Bdate должно быть меньше параметра DateToday

Function Age(Bdate, DateToday) As Integer
If Month(DateToday) < Month(Bdate) Or (Month(DateToday) = Month(Bdate) And Day(DateToday) < Day(Bdate)) Then
Age = Year(DateToday) - Year(Bdate) - 1
Else
Age = Year(DateToday) - Year(Bdate)
End If
End Function

Определение високосности года

Function LeapYear(YYYY As Integer) As Integer
'Функция возвращает -1, если указанный входной параметр (год) является високосным
'Пример: MsgBox LeapYear(1996)
LeapYear = YYYY Mod 4 = 0 And (YYYY Mod 100 <> 0 Or YYYY Mod 400 = 0)
End Function

Function LeapYear2(YYYY As Integer) As Integer
'Функция возвращает -1, если указанный входной параметр (год) является високосным
'Пример: MsgBox LeapYear(1996)
LeapYear2 = Month(DateSerial(YYYY, 2, 29)) = 2
End Function

Function IsLeapYear(DateIn As Date) As Boolean
'Функция возвращает True, если год в указанной дате является високосным
'Проверка: MsgBox IsLeapYear("01/01/00")
If IsDate("29/02/" & Format(DateIn, "yyyy")) = True Then
IsLeapYear = True
End If
End Function

Источник: http://www.vbnet.ru/