Date range

[shersu]

Hi all,

Is there a way to get the dates of all weeks of a month ranging from Saturday to Wednesday?

For example:

The first working day of Feb is Sunday. So the label displays as follows:

Label1(0)--> 01-04

Label1(1)--> 07-11

Label1(2)--> 14-18

Label1(3)--> 21-25

Label1(4)--> 28-29


Please help.

Thanks

[shersu]

This is what I have done. But it is not giving me the accurate range for the last week.

Dim lDay As Long
Dim lMonth As Long
Dim dtDate As Date
Dim Myint As Integer

Dim T1, T2
Myint = 0
dtDate = DTP.Value
lMonth = DatePart("m", dtDate)
lDay = DatePart("d", dtDate)
dtDate = dtDate - lDay + 1
T1 = DatePart("d", dtDate)
dtDate = dtDate + (4 - Weekday(dtDate))
T2 = DatePart("d", dtDate)

Do While lMonth = DatePart("m", dtDate)
Label1(Myint).Caption = T1 & "-" & Day(Format(dtDate, "Short Date"))
MsgBox T1 & "-" & Day(Format(dtDate, "Short Date"))
T1 = DatePart("d", (dtDate + 3))
dtDate = dtDate + 7
If DatePart("m", dtDate) = lMonth + 1 Then
Exit Do
End If
T2 = DatePart("d", dtDate)
Myint = Myint + 1
Load Label1(Myint)
Label1(Myint).Move 0, Label1(Myint - 1).Top + Label1(Myint - 1).Height + 10
Label1(Myint).Visible = True
Loop

Thanks.

[leinad31]

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

[shersu]

Thank you so much. Exactly what I wanted. But I noticed that, if the last day of the month is a Saturday, it counts to the 4th of the next month. Can that error be rectified?

Thanks

[leinad31]

I did that before I had to rush to a dinner date so I didn't check it

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, get wednesday in next week
         WeekWedDate = StartDate(DateAdd("d", 7, WeekLastStart), vbWednesday)
      Else
         WeekWedDate = StartDate(WeekLastStart, vbWednesday)
      End If
      
      booAddToList = False
      If (Month(WeekSatDate) = TheMonth) And (Month(WeekWedDate) = TheMonth) Then
         'Both within month
         booAddToList = True
      ElseIf Month(WeekSatDate) < TheMonth _
      And WeekWedDate > DateSerial(TheYear, TheMonth, 1) Then
         'Sat not within month
         'Adjust Start to first day of month, since first day is not wednesday
         WeekSatDate = DateSerial(TheYear, TheMonth, 1)
         booAddToList = True
      ElseIf (Month(WeekWedDate) > TheMonth) _
      And WeekSatDate < DateSerial(TheYear, TheMonth + 1, 1 - 1) Then
         'Wed not within month
         'Adjust wed to last day of month, since 2nd to the last day is not a sat
         WeekWedDate = DateSerial(TheYear, TheMonth + 1, 1 - 1)
         booAddToList = True
      'Else
         'Both not in month, ignore
      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
   StartDate = DateSerial(Year(InputDate), Month(InputDate), (Day(InputDate) - Weekday(InputDate, WeekFirstDay) + 1))
   'Or StartDate = DateAdd("d", 1 - WeekDay(InputDate, WeekFirstDay), InputDate)
End Function
 
Private Sub Command1_Click()
   Call GetWeeksInMonth(Month(Now))
End Sub

[shersu]

This does not display the last week at all.

Take for example, July. July has only one working day in the last week, that is, Saturday. I such conditions, it is better that the last label displays like 31-31. Same is the case with September too because, in the first week of September, there is only one working day, that is, 1. So the first label will better display 1-1.

Thanks

[leinad31]

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, get wednesday in next week
         WeekWedDate = StartDate(DateAdd("d", 7, WeekLastStart), vbWednesday)
      Else
         WeekWedDate = StartDate(WeekLastStart, vbWednesday)
      End If
      
      booAddToList = False
      If (Month(WeekSatDate) = TheMonth) And (Month(WeekWedDate) = TheMonth) Then
         'Both within month
         booAddToList = True
      ElseIf (Month(WeekSatDate) < TheMonth) And (Month(WeekWedDate) = TheMonth) Then
         'Sat not within month
         'Adjust Start to first day of month
         WeekSatDate = DateSerial(TheYear, TheMonth, 1)
         booAddToList = True
      ElseIf (Month(WeekSatDate) = TheMonth) And (Month(WeekWedDate) > TheMonth) Then
         'Wed not within month
         'Adjust wed to last day of month
         WeekWedDate = DateSerial(TheYear, TheMonth + 1, 1 - 1)
         booAddToList = True
      'Else
         'Both not in month, ignore
      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
   StartDate = DateSerial(Year(InputDate), Month(InputDate), (Day(InputDate) - Weekday(InputDate, WeekFirstDay) + 1))
   'Or StartDate = DateAdd("d", 1 - WeekDay(InputDate, WeekFirstDay), InputDate)
End Function
 
Private Sub Command1_Click()
   Call GetWeeksInMonth(Month(Now))
End Sub

[shersu]

Thanks. That was excellent! Thanks once again.