Public Function myWeekRange(WeekNum As Integer, Optional fmt As Integer = 0, Optional sdy As Integer = 0) As String
' fmt = Format options: Range = 0 to 8
' 0 = Week 17: 4/18/04 - 4/24/04 (default)
' 1 = Week 17: 4/18/2004 - 4/24/2004
' 2 = Week 17: April 18, 2004 - April 24, 2004
' 3 = Week 17: April 18 - 24, 2004
' 4 = 4/18/04 - 4/24/04
' 5 = 4/18/2004 - 4/24/2004
' 6 = 4/18 - 24/2004
' 7 = April 18, 2004 - April 24, 2004
' 8 = April 18 - 24, 2004
'
' sdy = Starting Day of Week options: Range = 0 to 6
' 0 = Sunday (default)
' 1 = Monday
' 2 = Tuesday (and so forth)
'
' USAGE:
' In the debug window, ?myWeekRange(17) will yield "Week 17: 4/18/04 - 4/24/04"
' In the debug window, ?myWeekRange(17,1) will yield "Week 17: 4/18/2004 - 4/24/2004"
' In the debug window, ?myWeekRange(17,1,1) will yield "Week 17: 4/19/2004 - 4/25/2004"
' In the debug window, ?myWeekRange(17,5,2) will yield "4/20/2004 - 4/26/2004"
' and so forth.
'
' You can also use it in queries: DtRng: myWeekRange(Format([Date],'ww'),1,1)
'
' Season to taste.
Dim StartDate As Date
Dim StartRange As Date
Dim EndRange As Date
Dim numDays As Long
Dim maxWk As Long
Dim fwDays As Long ' stores the number of days in the first week of the year
Dim dtTmpDate As Date
Dim i As Integer, w As String
Dim sdFmt As String ' stores the format string for the week start date
Dim edFmt As String ' stores the format string for the week end date
' Validate format option value and msg user if out of range
If fmt < 0 Or fmt > 8 Then
MsgBox "That is not a valid format option." & vbCrLf & vbCrLf & _
"Format options are:" & vbCrLf & _
" 0 = 'Week 17: 4/18/04 - 4/24/04' (default)" & vbCrLf & _
" 1 = 'Week 17: 4/18/2004 - 4/24/2004'" & vbCrLf & _
" 2 = 'Week 17: April 18, 2004 - April 24, 2004'" & vbCrLf & _
" 3 = 'Week 17: April 18 - 24, 2004'" & vbCrLf & _
" 4 = '4/18/04 - 4/24/04'" & vbCrLf & _
" 5 = '4/18/2004 - 4/24/2004'" & vbCrLf & _
" 6 = '4/18 - 24/2004'" & vbCrLf & _
" 7 = 'April 18, 2004 - April 24, 2004'" & vbCrLf & _
" 8 = 'April 18 - 24, 2004'", vbExclamation, "Invalid Week"
Exit Function
End If
' Validate first day of week (sdy) option value and msg user if out of range
If sdy < 0 Or sdy > 6 Then
MsgBox "That is not a valid First Day of Week option." & vbCrLf & vbCrLf & _
"Format options are:" & vbCrLf & _
" 0 = Sunday (default)" & vbCrLf & _
" 1 = Monday" & vbCrLf & _
" 2 = Tuesday" & vbCrLf & _
" 3 = Wednesday" & vbCrLf & _
" 4 = Thursday" & vbCrLf & _
" 5 = Friday" & vbCrLf & _
" 6 = Saturday", vbExclamation, "Invalid First Day of Week"
Exit Function
End If
' Determine the maximum week number of the current year
maxWk = Format(CDate(Format("12/31/" & Year(Now()), "m/d/yyyy")), "ww")
If WeekNum > maxWk Or WeekNum < 1 Then
MsgBox "That is not a valid week number.", vbExclamation, "Invalid Week"
Exit Function
End If
' Set the date of the first day of the current year
StartDate = CDate(Format("01/01/" & Year(Now()), "m/d/yyyy"))
dtTmpDate = DateSerial(Year(StartDate), Month(StartDate), 1)
' Determine the number of days in the first week of the current year
For i = 1 To 7
If WeekDay(dtTmpDate) = vbSunday Then
fwDays = Format(dtTmpDate, "d") - sdy
Exit For
End If
dtTmpDate = dtTmpDate + 1
Next i
' Establish the Date Ranges of the week
numDays = (7 * (WeekNum - 1)) - fwDays
StartRange = DateAdd("d", numDays, StartDate)
EndRange = DateAdd("d", 6, StartRange)
If fmt < 4 Then
w = "Week " & WeekNum & ": "
Else
w = ""
End If
' Render the Date Range output format
Select Case fmt
Case 0, 4
sdFmt = "m/d/yy"
edFmt = "m/d/yy"
Case 1, 5
sdFmt = "m/d/yyyy"
edFmt = "m/d/yyyy"
Case 2, 7
sdFmt = "mmmm d, yyyy"
edFmt = "mmmm d, yyyy"
Case 3
sdFmt = "mmmm/d"
edFmt = "d/yyyy"
Case 6
sdFmt = "m/d"
edFmt = "d/yyyy"
Case 8
sdFmt = "mmmm d"
edFmt = "d, yyyy"
Case Else
myWeekRange = "something broke"
Exit Function
End Select
' Render the Date Range output
myWeekRange = w & Format(StartRange, sdFmt) & " - " & Format(EndRange, edFmt)
End Function