VBA to create worksheets with dates of the month.

[danbates77]

Hi,

I have found a code that can create a whole months worth of worksheets/tabs with the dates of the month in thanks to @My Aswer Is This

Here is the code:

Sub Add_Sheet()
Application.ScreenUpdating = False
Dim ans As Date
Dim i As Long
On Error GoTo M
ans = InputBox("Enter Start Date") 'Range("A1").Value
    For i = 1 To 31
        Sheets("Master").Copy After:=Sheets(Sheets.Count)
        ActiveSheet.Name = Format(DateAdd("d", i - 1, ans), "dd/mm/yyyy")
    Next
Sheets("Master").Activate
Application.ScreenUpdating = True
Exit Sub
M:
MsgBox "Improper date entered in InputBox"
Application.ScreenUpdating = True
End Sub

If possible I would like to be able to alter this code so when it creates the new worksheets/tabs it creates 2 sheets/tabs per date and adds DAYS & NIGHTS in the name.

Example:
01/01/2021 - DAYS
01/01/2021 - NIGHTS
02/01/2021 - DAYS
02/01/2021 - NIGHTS and so on.

Any help would be appreciated if it's possible.

Thanks

Dan

 

[JLGWhiz]

See if this works for you

Sub Add_Sheet2()
Application.ScreenUpdating = False
Dim ans As Date
Dim i As Long
On Error GoTo M
ans = InputBox("Enter Start Date") 'Range("A1").Value
    For i = 1 To 31
        Sheets("Master").Copy After:=Sheets(Sheets.Count)
        Sheets(Sheets.Count).Name = Format(DateAdd("d", i - 1, ans), "dd/mm/yyyy") & " - Day"
        ActiveSheet.Copy After:=Sheets(Sheets.Count)
        Sheets(Sheets.Count).Name = Format(DateAdd("d", i - 1, ans), "dd/mm/yyyy") & " - Night"
    Next
Sheets("Master").Activate
Application.ScreenUpdating = True
Exit Sub
M:
MsgBox "Improper date entered in InputBox"
Application.ScreenUpdating = True
End Sub

 

[Logit]

Another method :

Option Explicit
Sub CreateSheets()
    Const lngFirstWorkDay = vbMonday
    Dim lngYear As Long
    Dim lngMonth As Long
    Dim lngOption As Long
    Dim rngHolidays As Range
    Dim d As Date
    Dim wsh As Worksheet
    Dim f As Boolean
    lngYear = Val(InputBox("For which year do you want to create sheets?"))
    
    If lngYear < 2000 Or lngYear > 2100 Then
        MsgBox "Year not valid! Please try again.", vbInformation
        Exit Sub
    End If
    
    lngMonth = Val(InputBox("For which month (1 ... 12) do you want to create sheets?"))
    
    If lngMonth < 1 Or lngMonth > 12 Then
        MsgBox "Month not valid! Please try again.", vbInformation
        Exit Sub
    End If
    
    lngOption = 1
    
    If lngOption < 1 Or lngOption > 1 Then
        MsgBox "Option not valid! Please try again.", vbInformation
        Exit Sub
    End If
    
    Application.ScreenUpdating = False
    
    d = DateSerial(lngYear, lngMonth, 1)
    
    Do
        f = True
        If f Then
            Set wsh = Worksheets.Add(After:=Worksheets(Worksheets.Count))
            wsh.Name = Format(d, "yyyy_mm_dd") & "- Days"
            Set wsh = Worksheets.Add(After:=Worksheets(Worksheets.Count))
            wsh.Name = Format(d, "yyyy_mm_dd") & "- Nights"
        End If
        
        d = d + 1
    
    Loop Until Month(d) <> lngMonth
    Sheets("Template").Activate
    Sheets("Template").Range("A1").Select
    Application.CutCopyMode = False
    
    Application.ScreenUpdating = True
    
    MsgBox "All Sheets Created", vbExclamation, "Sheet Creation"
    
End Sub

 

[danbates77]

Hi,

Both codes work perfectly, thank you both for your help.

Thanks

Dan

 

[Logit]

What format did you use when entering the date for your original macro ?

 

[danbates77]

Hi Logit,

I used 01/02/2021

I have just noticed one thing with your code. When I use it, it doesn't copy what's on the "Template" sheet to all the others. They are blank.

Any chance I could have it so it does copy from the "Template" sheet please?

Thanks

Dan

 

[Logit]

.
Look at this portion of the macro :

 Do
        f = True
        Sheets("Template").Range("A1:Z100").Copy    'adjust range in Template to copy here
        If f Then
            Set wsh = Worksheets.Add(After:=Worksheets(Worksheets.Count))
            wsh.Name = Format(d, "yyyy_mm_dd")
            Range("A1").PasteSpecial xlPasteAll
            Range("A1").PasteSpecial Paste:=xlPasteColumnWidths
            Range("A1").Select
        End If
        
        d = d + 1
    
    Loop Until Month(d) <> lngMonth