Option Explicit
Function ISOWeekNum(AnyDate As Date) As Long
'
'****************************************************************************************
' Title ISOWeekNum
' Target Application: any
' Function: computes ISO week number
' [from Chip Pearson's web site]
' The International Organization for Standardisation, based in Switzerland, issued
' Standard 8601 -- Representation Of Dates And Times, in 1988. This provides some
' standardization for "week numbers". Of course, compliance with these standards is
' entirely voluntary, so your business may or may not use the ISO definitions.
'
' Under the ISO standard, a week always begins on a Monday, and ends on a Sunday.
' The first week of a year is that week which contains the first Thursday of the year,
' or, equivalently, contains Jan-4.
'
' While this provides some standardization, it can lead to unexpected results --
' namely that the first few days of a year may not be in week 1 at all. Instead, they
' will be in week 52 of the preceding year! For example, the year 2000 began on
' Saturday. Under the ISO standard, weeks always begin on a Monday. In 2000, the
' first Thursday was Jan-6, so week 1 begins the preceding Monday, or Jan-3.
' Therefore, the first two days of 2000, Jan-1 and Jan-2, fall into week 52 of 1999.
'
' An ISO week number may be between 1 and 53. Under the ISO standard, week 1 will
' always have at least 4 days. If 1-Jan falls on a Friday, Saturday, or Sunday,
' the first few days of the year are defined as being in the last (52nd or 53rd)
' week of the previous year.
'
' Unlike absolute week numbers, not every year will have a week 53. For example,
' the year 2000 does not have a week 53. Week 52 begins on Monday, 25-Dec, and ends
' on Sunday, 31-Dec. But the year 2004 does have a week 53, from Monday, 27-Dec,
' through Friday, 31-Dec.
'
' Passed Values:
' AnyDate [input, date] a date in the week for which the ISO week number
' is desired
' Orig Date ~ 1999
' Orig Author John Green
' HISTORY
' 26Aug'05 MWE copied from Chip Pearson's web site;
' changed type to Long
' removed formating option (does not work for year 2000 - 2009)
' general commenting and cleanup
'
'****************************************************************************************
'
'
Dim NextFirstMonday As Date
Dim PreviousFirstMonday As Date
Dim ThisYear As Integer
Dim ThisFirstMonday As Date
Dim YearNum As Integer
ThisYear = Year(AnyDate)
ThisFirstMonday = FirstMonday(ThisYear)
PreviousFirstMonday = FirstMonday(ThisYear - 1)
NextFirstMonday = FirstMonday(ThisYear + 1)
Select Case AnyDate
Case Is >= NextFirstMonday
ISOWeekNum = (AnyDate - NextFirstMonday) \ 7 + 1
YearNum = Year(AnyDate) + 1
Case Is < ThisFirstMonday
ISOWeekNum = (AnyDate - PreviousFirstMonday) \ 7 + 1
YearNum = Year(AnyDate) - 1
Case Else
ISOWeekNum = (AnyDate - ThisFirstMonday) \ 7 + 1
YearNum = Year(AnyDate)
End Select
End Function
Function strISOWeekNum(AnyDate As Date, _
Optional FormatOut As Integer = 0) As String
'
'****************************************************************************************
' Title strISOWeekNum
' Target Application: any
' Function: computes ISO week number
'
' See comments on ISO Week Number in header for function ISOWeekNum
'
' Limitations: none
' Passed Values:
' AnyDate [input, date] a date in the week for which the ISO week number
' is desired
' FormatOut
' = 0, 1 returns ISO week number
' = 2 returns ISO week number embedded as YY##
' = 3 returns ISO week number embedded as 'YY##
' = 4 returns ISO week number embedded as YYYY##
' Orig Date ~ 1999
' Orig Author John Green
' HISTORY
' 26Aug'05 MWE copied from Chip Pearson's web site;
' changed type to string to accomodate various output formats
' revised passed parm for format options
' general commenting and cleanup
'
'****************************************************************************************
'
'
Dim ISOWkNum As Long
Dim NextFirstMonday As Date
Dim PreviousFirstMonday As Date
Dim ThisYear As Integer
Dim ThisFirstMonday As Date
Dim YearNum As Integer
ThisYear = Year(AnyDate)
ThisFirstMonday = FirstMonday(ThisYear)
PreviousFirstMonday = FirstMonday(ThisYear - 1)
NextFirstMonday = FirstMonday(ThisYear + 1)
Select Case AnyDate
Case Is >= NextFirstMonday
ISOWkNum = (AnyDate - NextFirstMonday) \ 7 + 1
YearNum = Year(AnyDate) + 1
Case Is < ThisFirstMonday
ISOWkNum = (AnyDate - PreviousFirstMonday) \ 7 + 1
YearNum = Year(AnyDate) - 1
Case Else
ISOWkNum = (AnyDate - ThisFirstMonday) \ 7 + 1
YearNum = Year(AnyDate)
End Select
Select Case FormatOut
Case Is = 0, 1
strISOWeekNum = Format(ISOWkNum, "00")
Case Is = 2
strISOWeekNum = Format(Right(YearNum, 2), "00") & _
Format(ISOWkNum, "00")
Case Is = 3
strISOWeekNum = "'" & Format(Right(YearNum, 2), "00") & _
Format(ISOWkNum, "00")
Case Is = 4
strISOWeekNum = Format(YearNum, "0000") & _
Format(ISOWkNum, "00")
End Select
End Function
Function FirstMonday(WhichYear As Integer) As Date
'
'****************************************************************************************
' Title FirstMonday
' Target Application: any
' Function: computes first Monday of any year
' Limitations: none
' Passed Values: WhichYear
' WhichYear [input, integer] the year for which the first Monday (date)
' is desired
' Orig Date ~ 1999
' Orig Author John Green
' HISTORY
' 26Aug'05 MWE copied from Chip Pearson's web site;
' changed name to FirstMonday;
' general commenting and cleanup
'
'****************************************************************************************
'
'
Dim NewYear As Date
Dim WeekDay As Integer
NewYear = DateSerial(WhichYear, 1, 1)
WeekDay = (NewYear - 2) Mod 7
If WeekDay < 4 Then
FirstMonday = NewYear - WeekDay
Else
FirstMonday = NewYear - WeekDay + 7
End If
End Function
Sub ISOWeekNum_Test()
'
'****************************************************************************************
' Title ISOWeekNum_Test
' Target Application: any
' Function: interacts with user for date and then calls ISOWeekNum and
' strISOWeekNum to compute ISO week number
'
' See comments on ISO Week Number in header for function ISOWeekNum
'
' Limitations: none
' Passed Values: none
' Orig Date 26-Aug-2005
' Orig Author MWE
' HISTORY
'
'****************************************************************************************
'
'
Dim strTemp As String
Dim TargetDate As Date
Dim Title As String
Title = "ISOWeekNum"
GetDate:
On Error Resume Next
strTemp = InputBox("enter any date in standard date format", Title)
If strTemp = "" Then Exit Sub
TargetDate = strTemp
If Err <> 0 Then
MsgBox "data entered is not in the form of a valid date." & vbCrLf & _
"click on CANCEL button to exit procedure.", vbCritical, Title
Goto GetDate:
End If
MsgBox "for entered date = " & Format(TargetDate, "dd-mmm-yyyy") & vbCrLf & vbCrLf & _
"return from ISOWeekNumber is " & ISOWeekNum(TargetDate) & vbCrLf & _
"return from strISOWeekNumber (FormatOut = 0) is " & strISOWeekNum(TargetDate) & vbCrLf & _
"return from strISOWeekNumber (FormatOut = 2) is " & strISOWeekNum(TargetDate, 2) & vbCrLf & _
"return from strISOWeekNumber (FormatOut = 3) is " & strISOWeekNum(TargetDate, 3) & vbCrLf & _
"return from strISOWeekNumber (FormatOut = 4) is " & strISOWeekNum(TargetDate, 4), _
vbInformation + vbOKOnly, Title
Goto GetDate
End Sub
|