# Adjusting Monthly Week Number Calculation VBA Code

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.
``````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
``````
###### Who is Participating?
I wear a lot of hats...

"The solutions and answers provided on Experts Exchange have been extremely helpful to me over the last few years. I wear a lot of hats - Developer, Database Administrator, Help Desk, etc., so I know a lot of things but not a lot about one thing. Experts Exchange gives me answers from people who do know a lot about one thing, in a easy to use platform." -Todd S.

Commented:

test this
``````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 = 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
``````
0

Experts Exchange Solution brought to you by

Your issues matter to us.

Facing a tech roadblock? Get the help and guidance you need from experienced professionals who care. Ask your question anytime, anywhere, with no hassle.

Author Commented:
That's it! Thank you. I imagine that wasn't too hard, since I did get the code from one of your posts ;)

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)
0
Commented:
this also

``````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
``````
0
Author Commented:
I meant to say,  (I imagine it would take me 30 or 40 hours to figure something like this out, if I could do it at all)
0
Author Commented:
On second thought, there's no way I could do this at my current skill level.
0
Commented:
you'll get there.. just be patient
0
Author Commented:
capricorn1, I ran into a little problem. The code doesn't seem to go to the next week when there is only one day in the next week. For example, both 1/31/10 and 2/28/10 fall into week 5 and 6, respectively. However, they show up as being in weeks 4 and 5.

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.
0
Author Commented:
I got these backwards up there.

1/31/10 is week 6

2/28/10 is week 5
0
Commented:
hmmm... please test this thoroughly. Iwant this to do the job correctly

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
``````
0
Author Commented:
Sorry, I'm running a  DatePart("ww", [Date]) along side the getWeekNumMon. 1/31/10 is in the 6th week of the year and 2/28/10 is in the 10th week. The getWeekNumMon is showing 1/31/10 as being in the 5th week and 2/28/10 in the 4th week.
0
Commented:
DatePart("ww", [Date]) and getWeekNumMon function are not the same

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
0
Author Commented:
I know. I was using that to help show where the error is occurring. DatePart  transitions from 1/30/10 (week 5) to 1/31/10 (week 6). However, GetWeekNumMon stays in Week 5.  I attached a query below. WeekNo is getWeekNumMon.
query.bmp
0
Commented:
test this
``````
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
``````
0
Author Commented:
Bingo! I can't wait until I'm at your level... in about 15-20 years :)
0
Author Commented:
Sorry, spoke too soon.
0
Author Commented:
It works between 1/30/10 and 1/31/10, but now it's not giving the right number at the beginning of the month.
query2.bmp
0
Commented:
pleas continue tessting

``````
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
``````
0
Author Commented:
Now you got it!

query3.JPG
0
Author Commented:
Thanks again for your help. You're very gifted. It definitely makes sense why you're number 1.
0
Commented:
i'm having a bad day...thank you for being there to test the function..
0
Commented:
jdallain

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
0
Author Commented:
Sorry, I didn't test the final one you gave me throughly enough. It worked between Dec. '09 and Feb '10 (the months I was concerned with at time), but it jumps around in other months. (e.g. 8/31/09 and 11/1/09)

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
0
###### It's more than this solution.Get answers and train to solve all your tech problems - anytime, anywhere.Try it for free Edge Out The Competitionfor your dream job with proven skills and certifications.Get started today Stand Outas the employee with proven skills.Start learning today for free Move Your Career Forwardwith certification training in the latest technologies.Start your trial today
Microsoft Access

From novice to tech pro — start learning today.