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

Open in new window

jdallainAsked:
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.

Rey Obrero (Capricorn1)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

Open in new window

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.

Start your 7-day free trial
jdallainAuthor 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
Rey Obrero (Capricorn1)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

Open in new window

0
The Ultimate Tool Kit for Technolgy Solution Provi

Broken down into practical pointers and step-by-step instructions, the IT Service Excellence Tool Kit delivers expert advice for technology solution providers. Get your free copy for valuable how-to assets including sample agreements, checklists, flowcharts, and more!

jdallainAuthor 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
jdallainAuthor Commented:
On second thought, there's no way I could do this at my current skill level.
0
Rey Obrero (Capricorn1)Commented:
you'll get there.. just be patient
0
jdallainAuthor 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
jdallainAuthor Commented:
I got these backwards up there.

1/31/10 is week 6

2/28/10 is week 5
0
Rey Obrero (Capricorn1)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

Open in new window

0
jdallainAuthor 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
Rey Obrero (Capricorn1)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
jdallainAuthor 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
Rey Obrero (Capricorn1)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

Open in new window

0
jdallainAuthor Commented:
Bingo! I can't wait until I'm at your level... in about 15-20 years :)
0
jdallainAuthor Commented:
Sorry, spoke too soon.
0
jdallainAuthor 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
Rey Obrero (Capricorn1)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

Open in new window

0
jdallainAuthor Commented:
Now you got it!


query3.JPG
0
jdallainAuthor Commented:
Thanks again for your help. You're very gifted. It definitely makes sense why you're number 1.
0
Rey Obrero (Capricorn1)Commented:
i'm having a bad day...thank you for being there to test the function..
0
Rey Obrero (Capricorn1)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
jdallainAuthor 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.