Untitled

Sub DuplicateSheets()
    Dim i As Integer
    Dim ws As Worksheet
    Dim newWS As Worksheet
    Dim sheetName As String
    Dim newSheetName As String
    
    ' Set the name of the original sheet to be duplicated
    sheetName = "Week1"
    
    ' Check if the sheet exists
    On Error Resume Next
    Set ws = ThisWorkbook.Sheets(sheetName)
    On Error GoTo 0
    
    ' If the sheet does not exist, show a message and exit the sub
    If ws Is Nothing Then
        MsgBox "Sheet '" & sheetName & "' does not exist.", vbCritical
        Exit Sub
    End If
    
    ' Loop to create new sheets and rename them
    For i = 2 To 100 ' Change this number to the total number of copies you want
        ' Create a unique sheet name
        newSheetName = "WEEK" & i
        Do While WorksheetExists(newSheetName)
            i = i + 1
            newSheetName = "WEEK" & i
        Loop
        
        ' Duplicate the original sheet
        ws.Copy After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
        
        ' Rename the new sheet
        Set newWS = ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
        newWS.Name = newSheetName
    Next i
End Sub

Function WorksheetExists(sheetName As String) As Boolean
    Dim ws As Worksheet
    On Error Resume Next
    Set ws = ThisWorkbook.Sheets(sheetName)
    On Error GoTo 0
    WorksheetExists = Not ws Is Nothing
End Function