Option Explicit
Private Function GetWeeksInMonth(TheMonth As Integer, Optional TheYear As Integer = -1)
Dim intDateIterate As Integer
Dim WeekSatDate As Date
Dim WeekWedDate As Date
Dim WeekLastStart As Date
Dim booAddToList As Boolean
If TheYear < 0 Then TheYear = Year(Now)
For intDateIterate = 1 To 36 Step 7 '1, 8, 15, 22, 29, 36
WeekLastStart = DateSerial(TheYear, TheMonth, intDateIterate)
WeekSatDate = StartDate(WeekLastStart, vbSaturday)
If StartDate(WeekLastStart, vbWednesday) < WeekSatDate Then
'Wednesday date before saturday date, adjust
WeekWedDate = StartDate(DateAdd("d", 7, WeekLastStart), vbWednesday)
Else
WeekWedDate = StartDate(WeekLastStart, vbWednesday)
End If
booAddToList = False
'Adjust ranges
If (WeekSatDate < DateSerial(TheYear, TheMonth, 1) _
And WeekWedDate < DateSerial(TheYear, TheMonth, 1)) _
Or (WeekSatDate > DateSerial(TheYear, TheMonth + 1, 1 - 1) _
And WeekWedDate > DateSerial(TheYear, TheMonth + 1, 1 - 1)) Then
'start and end before month
'or start end after month, ignore start-end
ElseIf WeekSatDate < DateSerial(TheYear, TheMonth, 1) _
And WeekWedDate > DateSerial(TheYear, TheMonth, 1) Then
'Adjust Start to first day of month, since first day is not wednesday
WeekSatDate = DateSerial(TheYear, TheMonth, 1)
booAddToList = True
ElseIf WeekSatDate < DateSerial(TheYear, TheMonth + 1, 1 - 1) _
And WeekWedDate > DateSerial(TheYear, TheMonth + 1, 1 - 1) Then
'Adjust wed to last day of month, since last day is not a sat
WeekWedDate = DateSerial(TheYear, TheMonth + 1, 1 - 1)
booAddToList = True
Else 'within Month
booAddToList = True
End If
If booAddToList = True Then
List1.AddItem Format(WeekSatDate, "dd") & " - " & Format(WeekWedDate, "dd")
End If
Next
End Function
Private Function StartDate(InputDate As Date, WeekFirstDay As Integer) As Date
'Function I use to get the date of the first day of the week
'where InputDate belongs to.
StartDate = DateSerial(Year(InputDate), Month(InputDate), (Day(InputDate) - Weekday(InputDate, WeekFirstDay) + 1))
End Function
Private Sub Command1_Click()
Call GetWeeksInMonth(Month(Now))
End Sub