Excel VBA script for week number and the weekly dates (Concatenated)

[sakrams]

Good Morning Excel Gurus,

I would really appreciate your support with the below excel VBA script to achieve the following scenario. For eg. Year 2024, I need a full list of week number with the dates as below (concatenated) for easy copy-paste.

Week starts from Monday to Sunday. For e.g.

(Week 1) - 01-Jan-2024 to 07-Jan-2024
(Week 2) - 08-Jan-2024 to 14-Jan-2024

I have been trying the following script, but getting compilation errors (Microsoft Excel 365). Any help from the gurus will be highly appreciated. Thanks in advance.

----------------------------------
Sub GenerateWeekList()

Dim year As Integer
Dim startDate As Date
Dim endDate As Date
Dim weekStartDate As Date
Dim weekEndDate As Date
Dim weekNumber As Integer
Dim i As Integer

' Input the year
year = InputBox("Enter the year:")

' Clear existing data
Range("A2:B" & Rows.Count).ClearContents

' Set starting date of the year
startDate = DateSerial(year, 1, 1)

' Loop through each week of the year
i = 0
Do
weekNumber = Application.WorksheetFunction.ISOWEEKNUM(startDate)
weekStartDate = WorksheetFunction.WorkDay(startDate, 0)
weekEndDate = WorksheetFunction.WorkDay(startDate, 6)

' Output week number and dates to worksheet
Cells(i + 2, 1).Value = "(Week " & weekNumber & ")"
Cells(i + 2, 2).Value = weekStartDate & " to " & weekEndDate

' Move to the next week
startDate = WorksheetFunction.WorkDay(startDate, 7)
i = i + 1
Loop While Year(startDate) = year
End Sub

 

[Cubist]

I'm no Guru but I had a similar code doing the same thing. I've modified it to your specifics. Try on a copy.

Sub GenerateWeekList()
    Dim yearStart As Date
    Dim yearEnd As Date
    Dim currentDate As Date
    Dim weekStartDate As Date
    Dim weekEndDate As Date
    Dim weekNumber As Long
    Dim weekList As String
    Dim ws As Worksheet
    Dim lastRow As Long
    Dim year As Variant
    Dim rowNum As Long
   
    Set ws = ThisWorkbook.Worksheets("Sheet1") '<~~~Change as needed
   
    year = InputBox("Enter the year:", "Year Input")
   
    If Not IsNumeric(year) Then
        MsgBox "Invalid year", vbExclamation
        Exit Sub
    End If
   
    yearStart = DateSerial(year, 1, 1) ' Start of the specified year
    yearEnd = DateSerial(year, 12, 31) ' End of the specified year
   
    lastRow = ws.Cells(ws.Rows.Count, "B").End(xlUp).Row
    If lastRow >= 2 Then
        ws.Range("B2:B" & lastRow).ClearContents
    End If
   
    rowNum = 2
   
    currentDate = yearStart
   
    Do While currentDate <= yearEnd
        weekStartDate = currentDate - Weekday(currentDate, vbMonday) + 1 ' Find Monday of the current week
        weekEndDate = weekStartDate + 6 ' Add 6 days to get Sunday of the current week
       
        weekNumber = WorksheetFunction.WeekNum(currentDate, vbMonday) ' Get the week number starting from Monday
       
        weekList = Format(weekStartDate, "dd-mmm-yyyy") & " to " & Format(weekEndDate, "dd-mmm-yyyy")
       
        ws.Cells(rowNum, 1).Value = weekNumber
        ws.Cells(rowNum, 2).Value = weekList
       
        rowNum = rowNum + 1
       
        currentDate = weekEndDate + 1 ' Move to the next Monday
    Loop
   
    MsgBox "Done", vbInformation
End Sub

 

[sakrams]

I'm no Guru but I had a similar code doing the same thing. I've modified it to your specifics. Try on a copy.

Sub GenerateWeekList()
    Dim yearStart As Date
    Dim yearEnd As Date
    Dim currentDate As Date
    Dim weekStartDate As Date
    Dim weekEndDate As Date
    Dim weekNumber As Long
    Dim weekList As String
    Dim ws As Worksheet
    Dim lastRow As Long
    Dim year As Variant
    Dim rowNum As Long
  
    Set ws = ThisWorkbook.Worksheets("Sheet1") '<~~~Change as needed
  
    year = InputBox("Enter the year:", "Year Input")
  
    If Not IsNumeric(year) Then
        MsgBox "Invalid year", vbExclamation
        Exit Sub
    End If
  
    yearStart = DateSerial(year, 1, 1) ' Start of the specified year
    yearEnd = DateSerial(year, 12, 31) ' End of the specified year
  
    lastRow = ws.Cells(ws.Rows.Count, "B").End(xlUp).Row
    If lastRow >= 2 Then
        ws.Range("B2:B" & lastRow).ClearContents
    End If
  
    rowNum = 2
  
    currentDate = yearStart
  
    Do While currentDate <= yearEnd
        weekStartDate = currentDate - Weekday(currentDate, vbMonday) + 1 ' Find Monday of the current week
        weekEndDate = weekStartDate + 6 ' Add 6 days to get Sunday of the current week
      
        weekNumber = WorksheetFunction.WeekNum(currentDate, vbMonday) ' Get the week number starting from Monday
      
        weekList = Format(weekStartDate, "dd-mmm-yyyy") & " to " & Format(weekEndDate, "dd-mmm-yyyy")
      
        ws.Cells(rowNum, 1).Value = weekNumber
        ws.Cells(rowNum, 2).Value = weekList
      
        rowNum = rowNum + 1
      
        currentDate = weekEndDate + 1 ' Move to the next Monday
    Loop
  
    MsgBox "Done", vbInformation
End Sub

@Cubist Excellent, this worked like a charm. Thanks a million for your support

 

[Rick Rothstein]

So we fully understand your requirements, what would Week 1 look like for the year 2027?

 

[sakrams]

@Rick Rothstein

January 2027, week 1 should start 4th January to 10th January. Week 1 should always start on the first Monday of January. In 2025 the first Monday is 6th January. Also, is it possible to run the script from Personal.xlt file on any open workbook?

 

[sakrams]

@Rick Rothstein Correction, I can't edit the post above.

52 weeks a year. 2025 - Week 1 to start 30th December 2024 to January 05, 2025.
2026 - Week 1 to start 29th December 2025 to January 04, 2026.

2027 week 1 should start on 4th Jan to 10 Jan. Also, is it possible to run the script from Personal.xlt file on any open workbook?

 

[Rick Rothstein]

What is the reasoning that for 2026, Week 1 starts on 29th December but for 2027 it starts on 4th January (why doesn't it start on 28th December)?

 

[sakrams]

I have an excel calendar that I follow for weekly reporting. I am trying to mimic the dates as per that calendar. For 2027, I see week 53 starting 28th December 2026 to Jan 3 2027.

What is the reasoning that for 2026, Week 1 starts on 29th December but for 2027 it starts on 4th January (why doesn't it start on 28th December)

 

[Cubist]

If the above code works for you this should be considerably faster.

Sub GenerateWeekList()
    Dim yearStart As Date, yearEnd As Date, currentDate As Date, weekStartDate As Date
    Dim weekEndDate As Date
    Dim weekNumber As Long
    Dim weekList() As Variant
    Dim ws As Worksheet
    Dim lastRow As Long
    Dim year As Variant
    Dim rowNum As Long
    Dim i As Long
    
    Application.ScreenUpdating = False
    Set ws = ThisWorkbook.Worksheets("Sheet1") '<~~~Change as needed
    year = InputBox("Enter the year:", "Year Input")
    If Not IsNumeric(year) Then
        MsgBox "Invalid year", vbExclamation
        Exit Sub
    End If
    yearStart = DateSerial(year, 1, 1) ' Start of the specified year
    yearEnd = DateSerial(year, 12, 31) ' End of the specified year
    lastRow = ws.Cells(ws.Rows.Count, "B").End(xlUp).Row
    If lastRow >= 2 Then
        ws.Range("B2:B" & lastRow).ClearContents
    End If
    rowNum = 2
    currentDate = yearStart
    i = 0
    ' Determine the number of weeks in the year
    
    Dim numWeeks As Long
    numWeeks = WorksheetFunction.WeekNum(yearEnd, vbMonday) - WorksheetFunction.WeekNum(yearStart, vbMonday) + 1
    ReDim weekList(1 To numWeeks, 1 To 2)
    Do While currentDate <= yearEnd
        weekStartDate = currentDate - Weekday(currentDate, vbMonday) + 1 ' Find Monday of the current week
        weekEndDate = weekStartDate + 6 ' Add 6 days to get Sunday of the current week
        weekNumber = WorksheetFunction.WeekNum(currentDate, vbMonday) ' Get the week number starting from Monday

        weekList(i + 1, 1) = weekNumber
        weekList(i + 1, 2) = Format(weekStartDate, "dd-mmm-yyyy") & " to " & Format(weekEndDate, "dd-mmm-yyyy")
        i = i + 1
        currentDate = weekEndDate + 1
    Loop
    
    ws.Range("A2").Resize(UBound(weekList, 1), UBound(weekList, 2)).Value = weekList
    Application.ScreenUpdating = True
    MsgBox "Done", vbInformation
End Sub