Automatically create new worksheet template daily with current date

I've created an Excel workshop to allow people track the different work activities they engage in over the working day (it's for a study we are doing). The idea is that everyone in my department will have a copy of the worksheet open on their computer at their desk and will record in realtime the different work activities they do over the day. I'm trying to make it as foolproof as possible by locking down everything except the cells they ned to complete.

My problem is that I want Excel to create new worksheet everyday that is labelled with the current date. However, I want this worksheet to be the template I created (e.g. column headings, formulas, etc) rather than a completely blank worksheet. I also want Excel to either do this automatically when the workbook is opened each day or else have a button on the workbook that the person clicks to do it.

I'm relatively new to Excel so have just been learning as I go along. I also don't have any knowledge of Visual Basic.

I've attached a copy of the workbook (the password for both the sheet and the workbook is thescientist

Any tips or help with this would be much appreciated.

Hi try this

I've named the sheet that you want to Copy as "Master" added a Button "Admin"

Added a New Sheet called Admin and added two buttons and assigned Macros to them

Button1. Amend "Master" Sheet password "lemonade"
Button2. Amend "Fields" Sheet password "lemonade



In the VBA editor, find the "ThisWorkbook" object and dbl click. You will get a window titled "bookName - ThisWorkbook". In the left dropdown select workbook and you should get a workbook open event procedure.

Try this and see if it does what you want.

Private Sub Workbook_Open()
Dim sht As Worksheet
Dim shtName As String
Dim aDate As Date


aDate = Int(Now())
aDate = aDate - (Weekday(aDate, vbMonday) - 1)
Application.ScreenUpdating = False
Call UnProtect("thescientist")
shtName = Format(aDate, "dd-mm-yyyy")
On Error Resume Next
Set sht = Sheets(shtName)
On Error GoTo 0
Application.ScreenUpdating = True

If (sht Is Nothing) Then
Application.ScreenUpdating = False
Sheets("Master").Copy After:=Sheets(Sheets.Count)
Sheets("Master").Visible = False
Sheets("Fields").Visible = False
Sheets("Admin").Visible = True
        Sheets("Master (2)").Visible = True
        Sheets("Master (2)").Select
        Sheets("Master (2)").Name = shtName
        
 Application.ScreenUpdating = True
End If
Call Protect("thescientist")

End Sub

I also added to Modules in the VBA

Module1

Option Explicit
Sub Protect(myPassword As String)
ActiveWorkbook.ActiveSheet.Protect Password:="thescientist"
ActiveWorkbook.Protect Password:=myPassword
End Sub


Sub UnProtect(myPassword As String)
ActiveWorkbook.ActiveSheet.UnProtect Password:="thescientist"
ActiveWorkbook.UnProtect Password:=myPassword
End Sub

Module2

Sub unHidesh()
Call UnProtect("thescientist")
Application.ScreenUpdating = False
Dim MyValue As Variant
MyValue = InputBox("Please Enter Your Password")
If MyValue = "lemonade" Then 'lemonade being the password
Sheets("Admin").Visible = True
Sheets("Admin").Activate
Else
MsgBox ("Password Incorrect")
End If
Application.ScreenUpdating = True
Call Protect("thescientist")
End Sub

Sub unHidesh1()
Call UnProtect("thescientist")
Application.ScreenUpdating = False
Dim MyValue As Variant
MyValue = InputBox("Please Enter Your Password")
If MyValue = "lemonade" Then 'lemonade being the password
Sheets("Master").Visible = True
Sheets("Master").Activate
Else
MsgBox ("Password Incorrect")
End If
Application.ScreenUpdating = True
Call Protect("thescientist")
End Sub

Sub unHidesh2()
Call UnProtect("thescientist")
Application.ScreenUpdating = False
Dim MyValue As Variant
MyValue = InputBox("Please Enter Your Password")
If MyValue = "lemonade" Then 'lemonade being the password
Sheets("Fields").Visible = True
Sheets("Fields").Activate
Else
MsgBox ("Password Incorrect")
End If
Application.ScreenUpdating = True
Call Protect("thescientist")
End Sub

Sub Hidesh()
Call UnProtect("thescientist")
Application.ScreenUpdating = False
Sheets("Master").Visible = False
Application.ScreenUpdating = True
Call Protect("thescientist")
End Sub

Hi,

Thanks a million for that. That's even better than I was hoping for. I seems to work perfectly. When I run it, it creates a new sheet labelled with the current date, exactly as I was looking for.

I assume that when the date changes (i.e. tomorrow) it will add another sheet with that date and so on each day so that the workbook will have a range of sheets (one for each day). Out of curiosity does it create the new sheet automatically when the date changes or when the workbook is first opened on a new date (either way is fine for me).

Thanks as well for adding the admin button, that's really handy. Is it possible to hide the admin sheet tab given that I can access it though the button? I've tried hiding it but every time I reopen the workbook it's visible again. It's not a big deal though.

I've attached the file again as I've made a few changes to the "Fields" sheet

Again, that's for all your help with this.

Hi there,

If you're in Crumlin Hospital then you're just up the road from me (in Rathgar)

Take a look at the attached workbook and see if it does what you need - it uses the following code:

Standard VBA CodeModule

Option Private Module
Option Explicit


'=========================================================================================
'=========================================================================================


Public Sub CreateDailyWorksheet()

    Const sDATE_FORMAT  As String = "dd-mm-yy"
    Const sPASSWORD     As String = "thescientist"

    Dim sSheetName      As String
    Dim frm             As F01_Calendar

    Set frm = New F01_Calendar

        frm.Show

'       Proceed only if a date was selected on the Calendar form
        If frm.SelectedDate <> 0 Then

            sSheetName = Format(frm.SelectedDate, sDATE_FORMAT)

'           Proceed only if no worksheet already exists for the selectted date
            If mbWorksheetAlreadyExists(sSheetName:=sSheetName) = False Then

                Application.ScreenUpdating = False

'                   Temporarily unhide the Template worksheet
                    wksTemplate.Visible = xlSheetVisible

'                       Create a copy of the Template worksheet
                        wksTemplate.Copy After:=ThisWorkbook.Worksheets("Main")

'                       Rename the copy of the Template worksheet
                        ActiveSheet.Name = sSheetName

'                   Re-hide the Template worksheet now that it has been copied
                    wksTemplate.Visible = xlSheetHidden

                Application.ScreenUpdating = True

            End If

        End If

        Unload frm

    Set frm = Nothing

End Sub


'=========================================================================================
'=========================================================================================


Private Function mbWorksheetAlreadyExists(sSheetName As String) As Boolean

'   This function indicates whether or not the proposed worksheet name is already in use

    Dim bWorksheetAlreadyExists As Boolean
    Dim wks                     As Worksheet

    bWorksheetAlreadyExists = False

    For Each wks In ThisWorkbook.Worksheets

        If wks.Name = sSheetName Then
            bWorksheetAlreadyExists = True
            Exit For
        End If

    Next wks

    If bWorksheetAlreadyExists = True Then

        MsgBox "A worksheet with the name """ & sSheetName & _
               """ already exists in this workbook", _
                vbExclamation, "Duplicate worksheet name"

    End If

    mbWorksheetAlreadyExists = bWorksheetAlreadyExists

End Function

Worksheet VBA CodeModule

Option Explicit


'=========================================================================================
'=========================================================================================


Private Sub Worksheet_SelectionChange(ByVal Target As Range)

'   Check cells for desired format to trigger the calendarfrm.show routine,
'   otherwise exit the sub

    Const iCALENDAR_HEIGHT  As Integer = 191

    Dim vaDateFormats       As Variant
    Dim vDateFormat         As Variant
    Dim frm                 As F01_Calendar

    vaDateFormats = Array("m/d/yy;@", "mmmm d yyyy")

    For Each vDateFormat In vaDateFormats

        If vDateFormat = Target.NumberFormat Then

            Set frm = New F01_Calendar

                With frm

                    If .HelpLabel.Caption <> vbNullString Then
                          .Height = iCALENDAR_HEIGHT + .HelpLabel.Height
                    Else: .Height = iCALENDAR_HEIGHT
                          .Show
                    End If

                    If .SelectedDate <> 0 Then
                        Target.Value = .SelectedDate
                    End If

                End With

                Unload frm

            Set frm = Nothing

        End If

    Next

End Sub

I've simplified the code for your Calendar form by using a Class and Collection approach - this avoids the need to have separate (i.e. 42) routines for each of the various Date buttons on the form.


Hope this helps - please let me know how you get on.

Regards,

Greg M

That's absolutely perfect.
Again, thanks a million for your help with this.

Your welcome,

also excellent design by Greg M

Hi again,

Many thanks Toonies for your kind words!

This is an interesting project so I've been playing around with it, and the latest version is attached.

This version doesn't require an Administrator to use passwords, but rather the buttons associated with Administrator tasks are hidden unless the current UserName is included in the "approved list" of Administrators. This list is maintained by editing the highlighted values in the statement below:

Private Sub Workbook_Open()

    Dim vAdministrator  As Variant
    Dim rLastCell       As Range
    Dim wksActive       As Worksheet
    Dim wks             As Worksheet

    Set wksActive = ActiveSheet

    Application.ScreenUpdating = False

        wksInformation.Activate
        wksInformation.Cells(1, 1).Select
        wksActive.Activate

        Call ButtonsAreVisible(bTrueOrFalse:=False)

        For Each vAdministrator In Array("Greg", "Vincent")

            If Application.UserName = CStr(vAdministrator) Then
                Call ButtonsAreVisible(bTrueOrFalse:=True)
                Exit For
            End If

        Next vAdministrator

'      The remaining code for this routine is not shown here

Hope you find the attached interesting and/or useful.

Regards,

Greg M