Sheets for every week + start and ending date of the week

[wimexcel]

Hi,

I'm new to this forum, so I hope I do it correct
For my school, I have to make a week schedule in excel with a sheet for every week of the year.
Each sheet is named after a week. In every sheet the weeknumber + start and ending date must be mentioned.

Now I use a list with all the weeks + start date and ending date of that week.

Sub Makeyear()
    Dim MyCell As Range, MyRange As Range
    
    Set MyRange = Sheets("weeks").Range("A1")
    Set MyRange = Range(MyRange, MyRange.End(xlDown))

    For Each MyCell In MyRange
        Sheets("scheme").Copy After:=Sheets(Sheets.Count) 'creates a new worksheet
        Sheets(Sheets.Count).Name = MyCell.Value ' renames the new worksheet
        
    Range("D34").Select
    ActiveCell = MyCell
    Range("B2").Select
        
    Next MyCell
    
End Sub

I can't find a way to input the start and ending date automatically.

Also, I'd like to make it without the list. A student will only have to input a a starting date and ending date. Excel will then automatically generated the weeks/sheet in between.

Is there a solution for this?

Thanks for your help

[xLJer]

You may be able to work with this and edit to suit your needs.
After receiving input for starting and ending dates, it copies the
scheme worksheet into weekly sheets named after the week number plus
starting and ending dates for the week, Sunday through Saturday.

A file is attached. When testing you can quickly delete all the sheets you've created
by (1) clicking on the first tab to be deleted, (2) scroll to the last tab to be deleted,
(3) hold down the shift key and click the last tab (4) right-click the last tab and choose Delete.

Sub Copy_WorkSheet()
'copy the scheme worksheet as new weekly sheets, beginning from startDate through endDate.
'sheet name to include the week number, week starting date, and week ending date.
Dim startDate As Date, endDate As Date, weekStart As Date
Dim day1 As String, wksName As String, strWeekNumber As String
Dim testDate As Date, inputDate As String
Dim response, msgText As String, isWorksheet As Boolean
Dim weekCounter As Integer, numberOfWeeks As Integer, j As Integer
    
    On Error GoTo Error_Handler
    Application.ScreenUpdating = False
    
    day1 = "Sun"
    
    inputDate = InputBox("Enter starting date as mm/dd/yyyy" & _
        vbCrLf & "or enter nothing to cancel.", "Start Date Input")
    If Len(inputDate) = 0 Then Exit Sub
    
    If Not IsDate(inputDate) Or Len(inputDate) < 8 Then
        MsgBox "Starting date " & inputDate & " is not a valid date. Exiting."
        Exit Sub
    End If
    
    startDate = CDate(inputDate)
    
    inputDate = InputBox("Enter ending date as mm/dd/yyyy" & _
        vbCrLf & "or enter nothing to cancel.", "End Date Input")
    If Len(inputDate) = 0 Then Exit Sub
    
    If Not IsDate(inputDate) Or Len(inputDate) < 8 Then
        MsgBox "Ending date " & inputDate & " is not a valid date. Exiting."
        Exit Sub
    End If
    
    endDate = CDate(inputDate)
    
    If endDate < startDate Then
        MsgBox "Ending date must be later than starting date." & vbCrLf & vbCrLf & _
            "You entered a starting date of " & startDate & " and the ending date " & endDate
        Exit Sub
    End If
   
    weekStart = startDate
    
    'calculate date of first day of starting week
    Do While Format(weekStart, "ddd") <> day1
        weekStart = weekStart - 1
    Loop
   
   numberOfWeeks = Application.WorksheetFunction.RoundUp(DateDiff("d", startDate, endDate) / 7, 0)
                 
    For j = 1 To numberOfWeeks
        'use the follwing 2 lines of code if weeks are only to be numbered sequentially
        'weekCounter = weekCounter + 1
        'strWeekNumber = CStr(weekCounter)
        
        'otherwise, use this line of code if week numbers are to be calculated from the date variable
        strWeekNumber = Format(weekStart, "ww")
        
        wksName = "Wk_" & strWeekNumber & "_" & Format(weekStart, "mmddyyyy") & _
            "_" & Format(weekStart + 6, "mmddyyyy")
        isWorksheet = Sheet_Exists(wksName)
        
        If isWorksheet Then
            msgText = "Worksheet " & wksName & " already exists." & vbCrLf & vbCrLf & _
                "Click Yes to continue this macro, or No to stop."
                    
            response = MsgBox(msgText, vbYesNo, "")
            If response <> 6 Then Exit Sub
        End If
        
        If Not isWorksheet Then
            Sheets("scheme").Copy After:=Sheets(Sheets.Count)   'creates a new worksheet
            Sheets(Sheets.Count).Name = wksName                 'renames the new worksheet
        End If
        
        weekStart = weekStart + 7
    
    Next
    
    Worksheets(1).Select
    Application.ScreenUpdating = True
    Exit Sub
    
Error_Handler:
    
        MsgBox "An unexpected error occurred." & vbCrLf & Err & vbCrLf & Err.Description
        Exit Sub

End Sub

Function Sheet_Exists(sSheetName As String) As Boolean
'return True is worksheet exists
Dim oWksheet As Worksheet, tmpBool As Boolean

    For Each oWksheet In ActiveWorkbook.Sheets
        If oWksheet.Name = sSheetName Then
            tmpBool = True
            Exit For
        End If
    Next

    Sheet_Exists = tmpBool

End Function

[wimexcel]

Hi xLJer,
Thanks for your help. Looks like a great solution for my problem. When testing your file for one month I get an error:

"An unexpected error occured
6 overloop"

[xLJer]

Look at the code in my previous post. There are 4 lines that have red font.
Make these changes to the code in the worksheet module.
As an alternative, you could copy and replace the whole procedure.

What is different is that the loop that copies sheets runs for the number of
weeks between start date and end date, and does not compare dates to end the loop.