Week Number of the Month with conditions - excel

Question

I like to know if it is possible to make a vba code to find the week number of a date with these conditions:
Friday is the first day of the week
If the week consists of two months, (for example: May 27,2016 to June 2,2016), the week number will be determined by the number of days in each month. In this case, the number of days in the may part of the week is greater so the week number is equal to 5.
I tried to make a solution in a spreadsheet but I can't seem to figure out how to convert it all into vba code. If anyone has an idea to how this could be done, it is greatly appreciated.
Here is my attempt on the solution:
spreadsheet (green for input) (blue for output)
spreadsheet with formulas

Answer 1

here's a not so elegant solution
Option Explicit
Sub main2()
Dim cell As Range
Dim date1 As Date, date2 As Date
Dim weeks1 As Long, weeks2 As Long
With Worksheets("weeks")
For Each cell In .Range("B2:B" & .Cells(.Rows.Count, "B").End(xlUp).Row)
date1 = cell.Value
date2 = cell.Offset(, 1).Value
weeks1 = DateDiff("ww", date1, "01/01/1900", vbFriday)
weeks2 = DateDiff("ww", dateadd("d", -Day(date1), date1), "01/01/1900", vbFriday)
If DatePart("m", date1) <> DatePart("m", date2) Then
If DateDiff("d", date1, dateadd("d", -Day(date2), date2)) >= 3 Then
If IsDate(cell.Offset(-1)) Then
cell.Offset(, 8) = cell.Offset(-1, 8) + 1
Else
cell.Offset(, 8) = weeks2 - weeks1
End If
Else
cell.Offset(, 8) = 1
End If
Else
If IsDate(cell.Offset(-1)) Then
cell.Offset(, 8) = IIf(cell.Offset(-1, 8) > 3, 1, cell.Offset(-1, 8) + 1)
Else
cell.Offset(, 8) = weeks2 - weeks1
End If
End If
Next cell
End With
End Sub

Answer 2

There is probably a better algorithm, but here is a UDF that, given any date, will return the Weeknumber of that date according to your specifications (if I have understood them correctly).
You can adapt to your specific requirements as necessary
Option Explicit
Function wnMonth(DT As Date)
Dim dtFF As Date
Dim dtLF As Date
Dim lWN As Long
'First and Last Fridays of current month
dtFF = DT + 8 - Day(DT) - Weekday(DT - Day(DT) + 8 - 6)
dtLF = dtFF + 28 + 7 * (Day(dtFF + 28) < Day(dtFF + 21))
If DT >= dtFF And DT < dtLF Then
lWN = Int((DT - dtFF) / 7) + 1
If Day(dtFF) > 4 Then
lWN = lWN + 1
End If
Else
If DT < dtFF Then
If Day(dtFF) > 4 Then
lWN = 1
Else
'First Friday prior month
dtFF = DateAdd("m", -1, dtFF)
dtFF = dtFF + 8 - Day(dtFF) - Weekday(dtFF - Day(dtFF) + 8 - 6)
'Last Friday prior month
dtLF = dtFF + 28 + 7 * (Day(dtFF + 28) < Day(dtFF + 21))
'First Friday weeknumber
If Day(dtFF) > 4 Then
lWN = 2
Else
lWN = 1
End If
'Last Friday weeknumber = DT weeknumber
lWN = lWN + (dtLF - dtFF) / 7
End If
Else 'DT > dtLF
'days left in the month
If (8 - Day(dtLF + 7)) < 4 Then
lWN = 1
Else
lWN = (dtLF - dtFF) / 7 + IIf(Day(dtFF) > 4, 2, 1)
End If
End If
End If
wnMonth = lWN
End Function