Function DaysInWeeks(dteMonthYear As Date) As String
Dim FDate As Date, LDate As Date, strPrint As String, intI As Integer
' Find the 1st date of this month
FDate = DateSerial(Year(dteMonthYear), Month(dteMonthYear), 1)
' Find the last date of this month
LDate = DateAdd("d", -1, DateSerial(Year(dteMonthYear), Month(dteMonthYear) + 1, 1))
' If the 1st date is Sunday, skip the FDate to the next day
' i.e. March 2002
If Format(FDate, "ddd") = "Sun" Then
FDate = DateAdd("d", 1, FDate)
End If
' If the last date is Sunday, move the LDate to the previous date
If Format(LDate, "ddd") = "Sun" Then
LDate = DateAdd("d", -1, LDate)
End If
intI = 1
If Format(FDate, "ddd") <> "Sat" Then
' If the first date is on Saturday, print "Week 1 FDate"
strPrint = "Week " & intI & " : " & FDate & " - "
Else
' Print "Week 1 : FDate -
strPrint = "Week " & intI & " : " & FDate & vbCrLf & _
"Week " & intI + 1 & " : " & DateAdd("d", 2, FDate) & " - "
intI = intI + 1
End If
' Loop from the FDate to the LDate
Do While FDate < LDate
' If the current date is Saturday
If Format(FDate, "ddd") = "Sat" Then
' If the next day is the LDate, exit the loop
' i.e. Nov 2002
If DateAdd("d", 1, FDate) = LDate Then
Exit Do
' If the next 2 days is the LDate, print "Week Int +1"
' i.e. April 2001
ElseIf DateAdd("d", 2, FDate) = LDate Then
strPrint = strPrint & FDate & vbCrLf & "Week " & intI + 1 & " : "
' This is normal case, print "Week intI : FDate -"
Else
intI = intI + 1
strPrint = strPrint & FDate & vbCrLf & "Week " & intI & _
" : " & DateAdd("d", 2, FDate) & " - "
End If
End If
' Move the current date to the next day
FDate = DateAdd("d", 1, FDate)
Loop
' Print the LDate to string
strPrint = strPrint & LDate
DaysInWeeks = strPrint
End Function
