NthWeekday (1 Viewer)

[Solo712]

Hi all,
like Michael, I have a homemade function which I would like folks to evaluate. Sometimes, when I finish my work I feel reasonably certain it is clean code. Sometimes I don't. This would be one instance when I have an inkling it could be done better.

The need for this function seems obvious. Very often in scheduling monthly events the formula says "1st Monday", "2nd Thursday", or "Last Sunday" in the month. I am working presently with Condo managers who set up their meetings with the Board of Directors in that fashion. I looked for such a function but did not find anything. So, I created one from scratch. It works ok but I am curious to see if there is a better solution out there.

The NthWeekday function has three arguments 1) string that formulates the weekday argument, 2) month, 3) year. It returns date.
The first argument expression expects "1st", "2nd" 3rd" "4th" or "Last" concatenated with the name of the weekday (only first three letters are checked i.e. "Thupsday" or "Frivolous" works for Thursday and Friday respectively!). So eg., to find out the 3rd Thursday of this month the arguments would be : NthWeekday("3rdThursday", Month(Date), Year(Date)) and last Sunday NthWeekday("LastSunday", Month(Date), Year(Date)).

Perhaps there is a better way to handle the makeshift condition the occasional 5th occurrence of the weekday in the month. But I could not come up with anything that I liked so I "plugged" the problem with the "Last" label which does not care if it is 4th or 5th occurence. At any rate: I would like to see if there are some other solutions out there. Thanks in advance.

Public Function NthWeekDay(NthWD As String, Wmo As Integer, Wyr As Integer) As Date
  Dim tdate As Date, firstorlastday As Integer, generic As Integer, ourwkday As Integer, tb As Integer
  Dim wname As String, wpos As Integer
 
  If InStr(UCase(NthWD), "LAST") Then
     tb = 0
     wname = Mid(NthWD, 5)
     tdate = DateAdd("m", 1, DateSerial(Wyr, Wmo, 1)) - 1
  ElseIf IsNumeric(Left(NthWD, 1)) Then
     tb = CInt(Left(NthWD, 1))
     wname = Mid(NthWD, 4)
     tdate = DateSerial(Wyr, Wmo, 1)
  Else
     tb = -1
  End If
 
  If tb > -1 And tb < 5 Then
    wpos = InStr("SUNMONTUEWEDTHUFRISAT", UCase(Left(wname, 3)))
    firstorlastday = Weekday(tdate)
    If wpos <> 0 Then
      generic = 1 + (wpos - 1) / 3
      If tb > 0 Then
        If generic < firstorlastday Then generic = generic + 7
        ourwkday = generic - firstorlastday + 1
        ourwkday = ourwkday + (tb - 1) * 7
        tdate = DateSerial(Year(tdate), Month(tdate), ourwkday)
      Else
        If generic > firstorlastday Then firstorlastday = firstorlastday + 7
        ourwkday = Day(tdate) - firstorlastday + generic
        tdate = DateSerial(Year(tdate), Month(tdate), ourwkday)
      End If
    Else
      tdate = 0
    End If
  Else
    tdate = 0
  End If
  NthWeekDay = tdate
End Function

Best,
Jiri

 

[John Big Booty]

At a very quick glance, some comments explaining the purpose/function of each section of the code would be handy

They really help when you come back to something like this after a time away if not those who you've asked to take a look at it for you

 

[Solo712]

At a very quick glance, some comments explaining the purpose/function of each section of the code would be handy

They really help when you come back to something like this after a time away if not those who you've asked to take a look at it for you

Well, I think I would be likely more confused by my comments than my code. It has happened to me on a number of occasions that I could not figure out later why I made such and such a comment to a code that was simple to read and had purpose other than the comment indicated.

But your point is fair. I thought that the procedure was self-explanatory but evidently I am biased. So, here is the annotated code. I included the trapping of data errors in the 2nd and 3rd argument. In case anyone is wondering, the tdate=0 condition is a trappable error to be handled by the calling routine. I do not put message boxes and such into functions.

I have also removed the redundant tdate redefinitions in forming the NthWeekDay date.

Best,
Jiri

Public Function NthWeekDay(NthWD As String, Wmo As Integer, Wyr As Integer) As Date
  Dim tdate As Date, firstorlastday As Integer, generic As Integer, ourwkday As Integer, tb As Integer
  Dim wname As String, wpos As Integer
 
  ' trap errors in the Wmo- month and Wyr- year arguments
  If Wmo < 1 or Wmo > 12 Then 
     tdate = 0
     Exit Function
  ElseIf  Wyr < 1900 or Wyr > 9999 Then 
     tdate = 0
     Exit Function
  EndIF   
 
  ' extract function arguments and parse the
  ' expression identifying the weekday in month:
  ' tb = -1  error, tb = 0 is last occurence of the weekday
  ' tb = 1 to 4 is the ordinal of the weekday sought
  '   
  If InStr(UCase(NthWD), "LAST") Then
     tb = 0
     wname = Mid(NthWD, 5)   ' weekday name 
     tdate = DateAdd("m", 1, DateSerial(Wyr, Wmo, 1)) - 1  ' establish last day
  ElseIf IsNumeric(Left(NthWD, 1)) Then
     tb = CInt(Left(NthWD, 1))
     wname = Mid(NthWD, 4) 'weekday name
     tdate = DateSerial(Wyr, Wmo, 1)  ' establish first day
  Else
     tb = -1
  End If
 
  If tb > -1 And tb < 5 Then    'the positional prefix is correct
    ' extract from the  1st argument the weekday's position 
    wpos = InStr("SUNMONTUEWEDTHUFRISAT", UCase(Left(wname, 3)))
    ' establish the weekday of the first or last day of month
    firstorlastday = Weekday(tdate)
    If wpos <> 0 Then   ' do we have a match to weekday ? 
      ' if yes, align the position in the sstring to the Access index of weekdays
      generic = 1 + (wpos - 1) / 3
      If tb > 0 Then  ' handle the 1st to 4th occurence
        If generic < firstorlastday Then generic = generic + 7
        ourwkday = generic - firstorlastday + 1
        ourwkday = ourwkday + (tb - 1) * 7
      Else                 ' handle the last occurence 
        If generic > firstorlastday Then firstorlastday = firstorlastday + 7
        ourwkday = Day(tdate) - firstorlastday + generic
      End If
    Else
      tdate = 0    ' error in the weekday portion of the 1st argument 
    End If
  Else
    tdate = 0   ' error in the positional prefix of the 1st argument
  End If
  NthWeekDay = DateSerial(Year(tdate), Month(tdate), ourwkday)
End Function

 

[jdraw]

Pat Hartman posted some sample date-related functions at
http://www.access-programmers.co.uk/forums/showthread.php?t=238821

Some of those may be useful to you, or you may wish to extend some or get some different ideas from what's there.

Good luck.