asked on

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

ASKER CERTIFIED SOLUTION

Rey Obrero (Capricorn1)

membership

This solution is only available to members.

To access this solution, you must be a member of Experts Exchange.

Start Free Trial

jdallain

ASKER

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)

Rey Obrero (Capricorn1)

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

jdallain

ASKER

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)

jdallain

ASKER

On second thought, there's no way I could do this at my current skill level.

Rey Obrero (Capricorn1)

you'll get there.. just be patient

jdallain

ASKER

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.

jdallain

ASKER

I got these backwards up there.

1/31/10 is week 6

2/28/10 is week 5

Rey Obrero (Capricorn1)

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

jdallain

ASKER

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.

Rey Obrero (Capricorn1)

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

jdallain

ASKER

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

Rey Obrero (Capricorn1)

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

jdallain

ASKER

Bingo! I can't wait until I'm at your level... in about 15-20 years :)

jdallain

ASKER

Sorry, spoke too soon.

jdallain

ASKER

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

Rey Obrero (Capricorn1)

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

jdallain

ASKER

Now you got it!

query3.JPG

jdallain

ASKER

Thanks again for your help. You're very gifted. It definitely makes sense why you're number 1.

Rey Obrero (Capricorn1)

i'm having a bad day...thank you for being there to test the function..

Rey Obrero (Capricorn1)

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

jdallain

ASKER

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