Rename worksheet names with entries from list

Option Explicit
Sub CreateSheetsAsPerList()
Dim LR As Long
Dim WkWS As Worksheet, Ws As Worksheet, Temp As Worksheet, xWs As Worksheet, TPWS As Worksheet
Dim StartAtRow, EndAtRow, RowCounter As Long
Dim c As Range
With Application
    .ScreenUpdating = False
    .DisplayStatusBar = True
    .StatusBar = "!!! Please Be Patient...Updating Records !!!"
    .EnableEvents = False
    .Calculation = xlManual
End With
Application.DisplayAlerts = False
For Each xWs In Application.ActiveWorkbook.Worksheets
    If xWs.Name <> "Week names and numbers" And xWs.Name <> "Template" Then
        xWs.Delete
    End If
Next
Application.DisplayAlerts = True

Set Temp = Worksheets("Template")
Set WkWS = Worksheets("Week names and numbers")
WkWS.Copy After:=WkWS
ActiveSheet.Name = "TP"
Set TPWS = ActiveSheet
TPWS.UsedRange.Value = TPWS.UsedRange.Value
StartAtRow = 2
EndAtRow = TPWS.Range("A" & Rows.Count).End(xlUp).Row

For RowCounter = StartAtRow To EndAtRow
    TPWS.Rows(RowCounter).Select
    Selection.Delete Shift:=xlUp
Next
LR = TPWS.Range("A" & Rows.Count).End(xlUp).Row
For Each c In TPWS.Range("A2:A" & LR)
    Set Ws = Nothing
    On Error Resume Next
    Set Ws = Worksheets(c.Value)
        If Ws Is Nothing Then
            Sheets("Template").Copy After:=Sheets(Sheets.Count)
            ActiveSheet.Name = Format(c.Value, "dd-mm-yy")
            ActiveSheet.Range("J4").Value = c.Value
            ActiveSheet.Range("I5").Value = c.Offset(0, 1).Value
            ActiveSheet.Range("D5").Value = c.Offset(0, 1).Value - 1
            ActiveSheet.Range("D6").Value = c.Offset(0, 1).Value - 1
        End If
Next c
Application.DisplayAlerts = False
TPWS.Delete
Application.DisplayAlerts = True
WkWS.Activate
WkWS.Range("A1").Select
MsgBox "Total " & Worksheets.Count - 2 & " Sheets Created"
With Application
    .ScreenUpdating = True
    .DisplayStatusBar = True
    .StatusBar = False
    .EnableEvents = True
    .Calculation = xlAutomatic
End With
End Sub

Select all Open in new window