The revolutionary project management tool is here! Plan visually with a single glance and make sure your projects get done.

I found some great code for calculating the week number of each month. It works. However, the code displays week number 1 as 0; week number 2 as 1; and so on. I'd like to have it display week 1 of each month as 1, week 2 as 2, week 3 as 3...

I can't figure out where it's assigning the initial value to change it from 0 to 1.

Thank you.

I can't figure out where it's assigning the initial value to change it from 0 to 1.

Thank you.

```
Function getWeekNumMon(d As Date) As Integer
If VarType(d) <> 7 Then
getWeekNumMon = 0
Exit Function
End If
Dim d1 As Date, d2 As Date, sunArr(), j, sunDate As Date
d1 = DateSerial(Year(d), Month(d), 1)
d2 = DateSerial(Year(d), Month(d) + 1, 0)
Select Case Weekday(d1)
Case 1 'Sunday
sunDate = d1: j = 1
Do Until sunDate >= d2
ReDim Preserve sunArr(j)
sunArr(j) = sunDate
sunDate = sunDate + 7: j = j + 1
Loop
Case 2 To 7
sunDate = d1 + 8 - (Weekday(d1)): j = 1
Do Until sunDate >= d2
ReDim Preserve sunArr(j)
sunArr(j) = sunDate
sunDate = sunDate + 7: j = j + 1
Loop
End Select
For j = 1 To UBound(sunArr)
If d = sunArr(j) Then
getWeekNumMon = j
Exit For
End If
If j < UBound(sunArr) Then
If d > sunArr(j) And d < sunArr(j + 1) Then
getWeekNumMon = j
Exit For
End If
Else
If d > sunArr(j) Then
getWeekNumMon = j
Exit For
End If
End If
Next
End Function
```

On a side not, I was wondering on a level of 1 to 10 (10 being hardest), how you would rate the difficultly of this code? How long would it take you to write something like this? (I imagine it would take 30 or 40 hours to figure something like this out, if I could do it at all)

```
Function getWeekNumMon(d As Date) As Integer
If VarType(d) <> 7 Then
getWeekNumMon = 0
Exit Function
End If
Dim d1 As Date, d2 As Date, sunArr(), j, sunDate As Date
d1 = DateSerial(Year(d), Month(d), 1)
d2 = DateSerial(Year(d), Month(d) + 1, 0)
Select Case Weekday(d1)
Case 1 'Sunday
sunDate = d1: j = 0
Do Until sunDate >= d2
ReDim Preserve sunArr(j)
sunArr(j) = sunDate
sunDate = sunDate + 7: j = j + 1
Loop
Case 2 To 7
sunDate = d1 + 8 - (Weekday(d1)): j = 0
Do Until sunDate >= d2
ReDim Preserve sunArr(j)
sunArr(j) = sunDate
sunDate = sunDate + 7: j = j + 1
Loop
End Select
For j = LBound(sunArr) To UBound(sunArr)
If d <= sunArr(j) Then
getWeekNumMon = j + 1
Exit For
End If
If j < UBound(sunArr) Then
If d > sunArr(j) And d < sunArr(j + 1) Then
getWeekNumMon = j + 1
Exit For
End If
Else
If d > sunArr(j) Then
getWeekNumMon = j + 1
Exit For
End If
End If
Next
End Function
```

The first code you gave me works better than the 2nd. The 2nd code seem to have a problem distinguishing between weeks 1 and 2.

post back here for the result

```
Function getWeekNumMon(d As Date) As Integer
If VarType(d) <> 7 Then
getWeekNumMon = 0
Exit Function
End If
Dim d1 As Date, d2 As Date, sunArr(), j, sunDate As Date
d1 = DateSerial(Year(d), Month(d), 1)
d2 = DateSerial(Year(d), Month(d) + 1, 0)
Select Case Weekday(d1)
Case 1 'Sunday
sunDate = d1: j = 0
Do While sunDate <= d2
ReDim Preserve sunArr(j)
sunArr(j) = sunDate
sunDate = sunDate + 7: j = j + 1
Loop
Case 2 To 7
sunDate = d1 + 8 - (Weekday(d1)): j = 0
Do While sunDate <= d2
ReDim Preserve sunArr(j)
sunArr(j) = sunDate
sunDate = sunDate + 7: j = j + 1
Loop
End Select
For j = LBound(sunArr) To UBound(sunArr)
If d <= sunArr(j) Then
getWeekNumMon = j + 1
Exit For
ElseIf j < UBound(sunArr) Then
If d > sunArr(j) And d < sunArr(j + 1) Then
getWeekNumMon = j + 2
Exit For
End If
ElseIf d > sunArr(j) Then
getWeekNumMon = j + 1
Exit For
End If
Next
End Function
```

DatePart("ww", [Date]) will count the week number for the year consecutively

getWeekNumMon function will get what week number a certain date is in a month

query.bmp

```
Function getWeekNumMon(d As Date) As Integer
If VarType(d) <> 7 Then
getWeekNumMon = 0
Exit Function
End If
Dim d1 As Date, d2 As Date, sunArr(), j, sunDate As Date
d1 = DateSerial(Year(d), Month(d), 1)
d2 = DateSerial(Year(d), Month(d) + 1, 0)
Select Case Weekday(d1)
Case 1 'Sunday
sunDate = d1: j = 0
Do While sunDate <= d2
ReDim Preserve sunArr(j)
sunArr(j) = sunDate
sunDate = sunDate + 7: j = j + 1
Loop
Case 2 To 7
sunDate = d1 + 8 - (Weekday(d1)): j = 0
Do While sunDate <= d2
ReDim Preserve sunArr(j)
sunArr(j) = sunDate
sunDate = sunDate + 7: j = j + 1
Loop
End Select
For j = LBound(sunArr) To UBound(sunArr)
If d < sunArr(j) Then
getWeekNumMon = j + 1
ElseIf d = sunArr(j) Then
getWeekNumMon = j + 2
Exit For
ElseIf j < UBound(sunArr) Then
If d > sunArr(j) And d < sunArr(j + 1) Then
getWeekNumMon = j + 2
Exit For
End If
ElseIf d > sunArr(j) Then
getWeekNumMon = j + 1
Exit For
End If
Next
End Function
```

query2.bmp

```
Function getWeekNumMon(d As Date) As Integer
If VarType(d) <> 7 Then
getWeekNumMon = 0
Exit Function
End If
Dim d1 As Date, d2 As Date, sunArr(), j, sunDate As Date
d1 = DateSerial(Year(d), Month(d), 1)
d2 = DateSerial(Year(d), Month(d) + 1, 0)
Select Case Weekday(d1)
Case 1 'Sunday
sunDate = d1: j = 0
Do While sunDate <= d2
ReDim Preserve sunArr(j)
sunArr(j) = sunDate
sunDate = sunDate + 7: j = j + 1
Loop
Case 2 To 7
sunDate = d1 + 8 - (Weekday(d1)): j = 0
Do While sunDate <= d2
ReDim Preserve sunArr(j)
sunArr(j) = sunDate
sunDate = sunDate + 7: j = j + 1
Loop
End Select
For j = LBound(sunArr) To UBound(sunArr)
If d < sunArr(j) Then
getWeekNumMon = j + 1
Exit For '<< Forgot to insert this line
ElseIf d = sunArr(j) Then
getWeekNumMon = j + 2
Exit For
ElseIf j < UBound(sunArr) Then
If d > sunArr(j) And d < sunArr(j + 1) Then
getWeekNumMon = j + 2
Exit For
End If
ElseIf d > sunArr(j) Then
getWeekNumMon = j + 1
Exit For
End If
Next
End Function
```

test this one

Public Function GetWeekNumMonA(varDate As Date) As Integer

GetWeekNumMonA = DateDiff("ww", DateSerial(Year(varDate), Month(varDate), 1), varDate, vbSunday) + 1

End Function

The one you sent today works. I think I understand it too :) I tested it over the course of 2 years and it hit every time.

Thanks for following up capricorn1!

James

test2.JPG

All Courses

From novice to tech pro — start learning today.

test this

Open in new window