Employee Work Schedule

Agnarr

Agnarr

New Member
Joined
Jan 15, 2023
Messages
29
Office Version
  1. 365
Platform
  1. Windows
Hello everyone.
I would like to create a button which when pressed should Create 12 New Sheets, each named after a month (JANUARY, FEBRUARY, etc) and each sheet should have the same appearance modeled after this one:
Πρόγραμμα Aqua 2024.xlsm
ABCDEFGHIJKLMNOPQRSTUVWXYZAAABACADAEAFAG
3ΔΕΚΕΜΒΡΙΟΣΔευΤριΤετΠεμΠαρΣαβΚυρΔευΤριΤετΠεμΠαρΣαβΚυρOver Time
4W1W2Employee Name27-Nov28-Nov29-Nov30-Nov01-Dec02-Dec03-Dec04-Dec05-Dec06-Dec07-Dec08-Dec09-Dec10-Dec
5 48.00ΜΠΑΡΜΠΑΣ09:0021:0009:0018:00SolTagDayOff09:0019:0009:0018:0013:0021:0009:0021:0009:0018:00SolTag58
6 45.00ΚΑΡΑΠΕΤΣΑΣ09:0017:0010:0018:00SolTag09:0018:0013:0021:00DayOff09:0021:0013:0021:0010:0018:00SolTag05
7  SolTagSolTag00
8  SolTagSolTag00
9  SolTagSolTag00
10  SolTagSolTag00
11  SolTagSolTag00
12  SolTagSolTag00
13  SolTagSolTag00
14  SolTagSolTag00
15ΔευΤριΤετΠεμΠαρΣαβΚυρΔευΤριΤετΠεμΠαρΣαβΚυρOver Time
16W3W4Employee Name11-Dec12-Dec13-Dec14-Dec15-Dec16-Dec17-Dec18-Dec19-Dec20-Dec21-Dec22-Dec23-Dec24-Dec
1748.0048.00ΜΠΑΡΜΠΑΣ09:0018:0011:0021:00DayOff13:0021:0009:0021:0009:0018:00SolTagDayOff09:0019:0009:0018:0013:0021:0009:0021:0009:0018:00SolTag88
1840.0040.00ΚΑΡΑΠΕΤΣΑΣDayOff09:0017:0010:0018:0009:0017:0009:0017:0010:0018:00SolTag10:0018:0013:0021:00DayOff09:0017:0013:0021:0010:0018:00SolTag00
19  SolTagSolTag00
20  SolTagSolTag00
21  SolTagSolTag00
22  SolTagSolTag00
23  SolTagSolTag00
24  SolTagSolTag00
25  SolTagSolTag00
26  SolTagSolTag00
27ΔευΤριΤετΠεμΠαρΣαβΚυρΔευΤριΤετΠεμΠαρΣαβΚυρOver Time
28W5W6Employee Name25-Dec26-Dec27-Dec28-Dec29-Dec30-Dec31-Dec01-Jan02-Jan03-Jan04-Jan05-Jan06-Jan07-Jan
2939.00 ΜΠΑΡΜΠΑΣNationalDayOff11:0021:00DayOff13:0021:0009:0021:0009:0018:00SolTagSolTag70
3040.00 ΚΑΡΑΠΕΤΣΑΣNationalDayOff09:0017:0010:0018:0009:0017:0009:0017:0010:0018:00SolTagSolTag00
31  SolTagSolTag00
32  SolTagSolTag00
33  SolTagSolTag00
34  SolTagSolTag00
35  SolTagSolTag00
36  SolTagSolTag00
37  SolTagSolTag00
38  SolTagSolTag00
ΔΕΚΕΜΒΡΙΟΣ
Cell Formulas
RangeFormula
F4,H4,J4,L4,N4,P4,R4,T4,V4,X4,Z4,AB4,AD4,F28,H28,J28,L28,N28,P28,R28,T28,V28,X28,Z28,AB28,AD28,F16,H16,J16,L16,N16,P16,R16,T16,V16,X16,Z16,AB16,AD16F4=D4+1
A5:A14,A29:A38,A17:A26A5=IF(D5="","",SUM(AH5:AN5))
B5:B14,B29:B38,B17:B26B5=IF(S5="","",SUM(AO5:AU5))
AF5:AG14,AF29:AG38,AF17:AG26AF5=IF(BM5=0,0,BM5)
D16,D28D16=AD4+1
Cells with Conditional Formatting
CellConditionCell FormatStop If True
D5:AE38Dates OccurringtodaytextNO
D5:AE38Expression=OR(D5="Day",D5="Off")textNO
D5:AE38Expression=OR(D5=0.416666666666667,D5=0.75,D5=0.458333333333333,D5=0.791666666666667)textNO
D5:AE38Expression=OR(D5="VACAY",D5="Sick",D5="Leave",D5="National",D5="DayOff",D5="Vacation",D5="Time",D5="sol",D5="tag")textNO
D5:AE38Expression=OR(D5=0.541666666666667,D5=0.875)textNO
D5:AE38Expression=OR(D5=0.375,D5=0.708333333333333)textNO
D5:O14,R5:AC14,D17:O26,R17:AC26,D29:O38,R29:AC38Expression=OR(D5=0.416666666666667,D5=0.75,D5=0.458333333333333,D5=0.791666666666667)textNO
Cells with Data Validation
CellAllowCriteria
D5:AE14List=Holidays!$F$1:$F$12
D29:AE38List=Holidays!$F$1:$F$12
D17:AE26List=Holidays!$F$1:$F$12

Note that there is a vba code that should apply to all new sheets:
VBA Code: 
Private Sub Worksheet_Change(ByVal Target As Range)
    Dim inputR As Range, codeR As Range, cell As Range
    Dim f, fnd As Range
        Set inputR = Range("c4:ad70")
    If Intersect(Target, inputR) Is Nothing Then Exit Sub
        Application.ScreenUpdating = False
       ' Check if the changed cell is being deleted or changed to nothing
   If WorksheetFunction.CountBlank(Target) > 0 Then Exit Sub
    Set fnd = Sheets("Holidays").Range("F:F").Find(Target.Value, LookIn:=xlValues, LookAt:=xlWhole)
    If Not fnd Is Nothing Then
        Target.Offset(, 1) = fnd.Offset(, 2)
    End If
    Application.ScreenUpdating = True
    Set codeR = Worksheets("Holidays").Range("F:F")
    If Target.CountLarge > 1 Then Exit Sub
    With Application
        .EnableEvents = False
        For Each cell In Target
            ' Check if the cell value is being deleted or changed to nothing
            If cell.Value <> "" Then
                Set f = codeR.Find(cell.Value, , , xlWhole)
                If Not f Is Nothing Then cell.Value = f.Offset(, 1).Value
            End If
        Next
        .EnableEvents = True
    End With
End Sub

Any help or recommendations of how i could do something like that will be most appreciated.
Thank you all in advance.
 

Excel Facts

How can you turn a range sideways?
Copy the range. Select a blank cell. Right-click, Paste Special, then choose Transpose.
Sort by date Sort by votes
Agnarr said:
Hello everyone.
I would like to create a button which when pressed should Create 12 New Sheets, each named after a month (JANUARY, FEBRUARY, etc) and each sheet should have the same appearance modeled after this one:
Πρόγραμμα Aqua 2024.xlsm
ABCDEFGHIJKLMNOPQRSTUVWXYZAAABACADAEAFAG
3ΔΕΚΕΜΒΡΙΟΣΔευΤριΤετΠεμΠαρΣαβΚυρΔευΤριΤετΠεμΠαρΣαβΚυρOver Time
4W1W2Employee Name27-Nov28-Nov29-Nov30-Nov01-Dec02-Dec03-Dec04-Dec05-Dec06-Dec07-Dec08-Dec09-Dec10-Dec
5 48.00ΜΠΑΡΜΠΑΣ09:0021:0009:0018:00SolTagDayOff09:0019:0009:0018:0013:0021:0009:0021:0009:0018:00SolTag58
6 45.00ΚΑΡΑΠΕΤΣΑΣ09:0017:0010:0018:00SolTag09:0018:0013:0021:00DayOff09:0021:0013:0021:0010:0018:00SolTag05
7  SolTagSolTag00
8  SolTagSolTag00
9  SolTagSolTag00
10  SolTagSolTag00
11  SolTagSolTag00
12  SolTagSolTag00
13  SolTagSolTag00
14  SolTagSolTag00
15ΔευΤριΤετΠεμΠαρΣαβΚυρΔευΤριΤετΠεμΠαρΣαβΚυρOver Time
16W3W4Employee Name11-Dec12-Dec13-Dec14-Dec15-Dec16-Dec17-Dec18-Dec19-Dec20-Dec21-Dec22-Dec23-Dec24-Dec
1748.0048.00ΜΠΑΡΜΠΑΣ09:0018:0011:0021:00DayOff13:0021:0009:0021:0009:0018:00SolTagDayOff09:0019:0009:0018:0013:0021:0009:0021:0009:0018:00SolTag88
1840.0040.00ΚΑΡΑΠΕΤΣΑΣDayOff09:0017:0010:0018:0009:0017:0009:0017:0010:0018:00SolTag10:0018:0013:0021:00DayOff09:0017:0013:0021:0010:0018:00SolTag00
19  SolTagSolTag00
20  SolTagSolTag00
21  SolTagSolTag00
22  SolTagSolTag00
23  SolTagSolTag00
24  SolTagSolTag00
25  SolTagSolTag00
26  SolTagSolTag00
27ΔευΤριΤετΠεμΠαρΣαβΚυρΔευΤριΤετΠεμΠαρΣαβΚυρOver Time
28W5W6Employee Name25-Dec26-Dec27-Dec28-Dec29-Dec30-Dec31-Dec01-Jan02-Jan03-Jan04-Jan05-Jan06-Jan07-Jan
2939.00 ΜΠΑΡΜΠΑΣNationalDayOff11:0021:00DayOff13:0021:0009:0021:0009:0018:00SolTagSolTag70
3040.00 ΚΑΡΑΠΕΤΣΑΣNationalDayOff09:0017:0010:0018:0009:0017:0009:0017:0010:0018:00SolTagSolTag00
31  SolTagSolTag00
32  SolTagSolTag00
33  SolTagSolTag00
34  SolTagSolTag00
35  SolTagSolTag00
36  SolTagSolTag00
37  SolTagSolTag00
38  SolTagSolTag00
ΔΕΚΕΜΒΡΙΟΣ
Cell Formulas
RangeFormula
F4,H4,J4,L4,N4,P4,R4,T4,V4,X4,Z4,AB4,AD4,F28,H28,J28,L28,N28,P28,R28,T28,V28,X28,Z28,AB28,AD28,F16,H16,J16,L16,N16,P16,R16,T16,V16,X16,Z16,AB16,AD16F4=D4+1
A5:A14,A29:A38,A17:A26A5=IF(D5="","",SUM(AH5:AN5))
B5:B14,B29:B38,B17:B26B5=IF(S5="","",SUM(AO5:AU5))
AF5:AG14,AF29:AG38,AF17:AG26AF5=IF(BM5=0,0,BM5)
D16,D28D16=AD4+1
Cells with Conditional Formatting
CellConditionCell FormatStop If True
D5:AE38Dates OccurringtodaytextNO
D5:AE38Expression=OR(D5="Day",D5="Off")textNO
D5:AE38Expression=OR(D5=0.416666666666667,D5=0.75,D5=0.458333333333333,D5=0.791666666666667)textNO
D5:AE38Expression=OR(D5="VACAY",D5="Sick",D5="Leave",D5="National",D5="DayOff",D5="Vacation",D5="Time",D5="sol",D5="tag")textNO
D5:AE38Expression=OR(D5=0.541666666666667,D5=0.875)textNO
D5:AE38Expression=OR(D5=0.375,D5=0.708333333333333)textNO
D5:O14,R5:AC14,D17:O26,R17:AC26,D29:O38,R29:AC38Expression=OR(D5=0.416666666666667,D5=0.75,D5=0.458333333333333,D5=0.791666666666667)textNO
Cells with Data Validation
CellAllowCriteria
D5:AE14List=Holidays!$F$1:$F$12
D29:AE38List=Holidays!$F$1:$F$12
D17:AE26List=Holidays!$F$1:$F$12

Note that there is a vba code that should apply to all new sheets:
VBA Code: 
Private Sub Worksheet_Change(ByVal Target As Range)
    Dim inputR As Range, codeR As Range, cell As Range
    Dim f, fnd As Range
        Set inputR = Range("c4:ad70")
    If Intersect(Target, inputR) Is Nothing Then Exit Sub
        Application.ScreenUpdating = False
       ' Check if the changed cell is being deleted or changed to nothing
   If WorksheetFunction.CountBlank(Target) > 0 Then Exit Sub
    Set fnd = Sheets("Holidays").Range("F:F").Find(Target.Value, LookIn:=xlValues, LookAt:=xlWhole)
    If Not fnd Is Nothing Then
        Target.Offset(, 1) = fnd.Offset(, 2)
    End If
    Application.ScreenUpdating = True
    Set codeR = Worksheets("Holidays").Range("F:F")
    If Target.CountLarge > 1 Then Exit Sub
    With Application
        .EnableEvents = False
        For Each cell In Target
            ' Check if the cell value is being deleted or changed to nothing
            If cell.Value <> "" Then
                Set f = codeR.Find(cell.Value, , , xlWhole)
                If Not f Is Nothing Then cell.Value = f.Offset(, 1).Value
            End If
        Next
        .EnableEvents = True
    End With
End Sub

Any help or recommendations of how i could do something like that will be most appreciated.
Thank you all in advance.
Click to expand...
This code will duplicate the template worksheet and the code in the template worksheet will be copied.

VBA Code: 
Private Sub subDuplicateTemplate()
Dim i As Integer

  For i = 1 To 12
  
    '          Here   \/\/\/\/
    Worksheets("Template").Copy After:=Worksheets(Sheets.Count)
    ' CHANGE THE ABOVE LINE TO REFERENCE THE CORRECT TEMPLATE WORKSHEET.
    
    ActiveSheet.Name = Format(DateSerial(2000, i, 1), "MMMM")
  
  Next i

End Sub

Maintaining 12 copies of the same code may be difficult so I would create the code that you have submitted in a standard code module
and call that code from the worksheet_change event sub.

VBA Code: 
Public Sub subMonthWorksheet_Change(ByVal Target As Range)

  ' Put your code here.

End Sub

Call the code like this.

VBA Code: 
Private Sub Worksheet_Change(ByVal Target As Range)

  Call subMonthWorksheet_Change(Target)
  
End Sub
 
Upvote 0
You must log in or register to reply here.

Similar threads

Agnarr
  • Question Question
Cell substitution problem
Replies
5
Views
536
Alex Blakenburg
A
F
  • Question Question
cut defined cells from a sheet paste them on another sheet then delete incompletes rows
Replies
2
Views
732
Flavien
F
T
  • Solved
Smart Table
2
Replies
12
Views
2K
Tofik
T
T
  • Solved
Brain Error ( not for everyone )
Replies
6
Views
706
Tofik
T
K
  • Solved
Help with Macro, as it is not extracting all the data.
Replies
7
Views
969
Fluff
Fluff

Forum statistics

Threads
1,224,817
Messages
6,181,149
Members
453,021
Latest member
Justyna P

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top