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?

[Webinar] Streamline your web hosting managementRegister Today

x
 
Rey Obrero (Capricorn1)Connect With a Mentor 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
 
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
Never miss a deadline with monday.com

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

 
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
All Courses

From novice to tech pro — start learning today.