Help solve this pointless puzzle? "5 fridays 5 saturdays and 5 sundays in a month"

[Phil Smith]

I have come up against a bit of a conundrum.

I received an email that stated:

"This year's July has 5 fridays 5 saturdays and 5 sundays this apparently happens once every 823 years".

Looking throught the Windows calender it appears that it happens in months with 31 months when the 1st of the month falls on a Firday and not just in July.

I would like to start checking back from 1900 until 2099 for months with "5 fridays 5 saturdays and 5 sundays" but am unsure as to how to go about it.

I know this is a completey worthless task and seemingly pointless, but it has me intrigued.

Any solution, VBA or not is welcome!

 

[RoryA]

A bit brute force, but it's certainly more often than that email thinks:

Sub GetFiveMonths()
   Dim lngYear As Long, lngMonth As Long
   Dim dteTest As Date
   Dim rngOut As Range
   lngYear = 1900
   lngMonth = 1
   Set rngOut = ActiveSheet.Range("A1")
   dteTest = DateSerial(lngYear, lngMonth, 1)
   Do
      If Weekday(dteTest, 2) = 5 And Day(DateSerial(lngYear, lngMonth + 1, 0)) = 31 Then
         rngOut.Value = dteTest
         Set rngOut = rngOut.Offset(1)
      End If
      lngMonth = lngMonth + 1
      dteTest = DateSerial(lngYear, lngMonth, 1)
   Loop While Year(dteTest) < 2100
End Sub

 

[Ruddles]

Here's my attempt:-

Option Explicit
 
Sub Find5x31()
 
  Dim iYear As Integer
  Dim iMonth As Integer
  Dim iRow As Long
  
  For iYear = 1900 To 2099
    For iMonth = 1 To 12
      If iMonth = 2 Or iMonth = 4 Or iMonth = 6 Or iMonth = 9 Or iMonth = 11 Then iMonth = iMonth + 1
      If DateSerial(iYear, iMonth, 1) Mod 7 = vbFriday Then
        iRow = iRow + 1
        Cells(iRow, 1) = DateSerial(iYear, iMonth, 1)
        Cells(iRow, 1).NumberFormat = "mmmm yyyy"
      End If
    Next iMonth
  Next iYear
 
End Sub

 

[Phil Smith]

Thanks to you both for solving that pointless conundrum.

Interesting to see how facts stack up against a hoax/spam email though!

Cheers!

Phil