Public Sub atoCreate()
Dim WB As Workbook: Set WB = Workbooks.Add
Dim WS As Worksheet: Set WS = WB.Worksheets(1)
Dim YY As Long, MM As Long, B As Long
Dim DefltPath As String
DefltPath = Environ("USERPROFILE") & "\Desktop\"
YY = 2020
MM = 9
Dim Rng As Range
With WS
.Name = "Monthly Sign Sheet"
.Activate
ActiveWindow.DisplayGridlines = False
With .Cells(1, 1)
.Value = YY
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.RowHeight = 25
End With
With .Cells(1, 2)
.Value = MM
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
End With
With .Cells(3, 1).Resize(1, 5)
.Value = Array("Day/Date", "Time In", "Parent Signture", "Time Out", "Parent Signture")
With .Interior
.Pattern = xlSolid
.Color = RGB(47, 117, 181)
End With ' .Interior
With .Font
.Color = RGB(255, 255, 255)
End With ' .Font
.ColumnWidth = VBA.Array(15, 20, 25, 20, 25)
.RowHeight = 30
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.WrapText = False
End With ' .Cells(3, 1).Resize(1, 5)
With .Cells(4, 1).Resize(25, 1)
.FormulaArray = "=TEXT(DATE($A$1,$B$1,(ROW()-ROW($A$4)+1))+(((CEILING((ROW()-ROW($A$4)+1)+IF(WEEKDAY(DATE($A$1,$B$1,1))=1,WEEKDAY(DATE($A$1,$B$1,1))+1-2,WEEKDAY(DATE($A$1,$B$1,1))-2),5)/5)-1)*2)+IF(WEEKDAY(DATE($A$1,$B$1,1))=1,1,0),""dddd"" & CHAR(10) & "" mm/dd/yyyy"")"
.WrapText = True
.RowHeight = 35
.VerticalAlignment = xlCenter
End With ' .Cells(4, 1).Resize(30, 1)
With .Cells(3, 1).Resize(26, 5)
For B = 7 To 12
With .Borders(B)
.LineStyle = xlContinuous
.Color = RGB(0, 0, 0)
.Weight = xlThin
End With
Next
End With ' .Cells(3, 1).Resize(31, 1)
With Range("A27:E27")
.FormatConditions.Add Type:=xlExpression, Formula1:= _
"=MONTH(TRIM(MID($A$27,FIND(CHAR(10),$A$27,1)+2,10)))<>$B$1"
.FormatConditions(.FormatConditions.Count).SetFirstPriority
With .FormatConditions(1).Font
.ThemeColor = xlThemeColorDark1
.TintAndShade = 0
End With
.FormatConditions(1).Borders(xlLeft).LineStyle = xlNone
.FormatConditions(1).Borders(xlRight).LineStyle = xlNone
.FormatConditions(1).Borders(xlBottom).LineStyle = xlNone
.FormatConditions(1).StopIfTrue = False
End With
With Range("A28:E28")
.FormatConditions.Add Type:=xlExpression, Formula1:= _
"=MONTH(TRIM(MID($A$28,FIND(CHAR(10),$A$28,1)+2,10)))<>$B$1"
.FormatConditions(.FormatConditions.Count).SetFirstPriority
With .FormatConditions(1).Font
.ThemeColor = xlThemeColorDark1
.TintAndShade = 0
End With
.FormatConditions(1).Borders(xlLeft).LineStyle = xlNone
.FormatConditions(1).Borders(xlRight).LineStyle = xlNone
.FormatConditions(1).Borders(xlBottom).LineStyle = xlNone
.FormatConditions(1).StopIfTrue = False
End With
With .Spinners.Add(.Cells(1, 1).Left, .Cells(1, 1).Top, 18, .Cells(1, 1).Height)
.Value = 2020
.Min = 2015
.Max = 2040
.SmallChange = 1
.LinkedCell = "$A$1"
.Display3DShading = False
End With
With .Spinners.Add(.Cells(1, 2).Left, .Cells(1, 1).Top, 18, .Cells(1, 1).Height)
.Value = 11
.Min = 1
.Max = 12
.SmallChange = 1
.LinkedCell = "$B$1"
.Display3DShading = False
End With
On Error Resume Next
Kill DefltPath & "Monthly Sign in Sheet.xlsm"
.Parent.SaveAs Filename:=DefltPath & "Monthly Sign in Sheet.xlsm", FileFormat:=xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False
On Error GoTo 0
End With ' WS
End Sub
