Option Explicit
Sub CreateInputWorksheet()
GenerateWorksheetDates
InsertNames
FormatDateRows
End Sub
Sub UpdateTallySheet()
Dim iAnswer As VbMsgBoxResult
Dim sWorksheet As String
Dim bFail As Boolean
sWorksheet = Worksheets("Employees").Range("L1").Value
'Ensure valid worksheet specified
If Len(sWorksheet) <> 8 Then bFail = True: GoTo End_Sub
On Error Resume Next
If Worksheets(sWorksheet).Range("A1") <> "Monday" Then bFail = True: GoTo End_Sub
If Err.Number <> 0 Then bFail = True: GoTo End_Sub
'Check for existing tally worksheet for specified attendance worksheet
If Worksheets(sWorksheet).Range("A1") <> "Monday" Then bFail = True 'but just checking for worksheet presence
If Err.Number <> 0 Then
iAnswer = MsgBox("The 'Tally " & sWorksheet & " worksheet already exists. Delete it?", vbOKCancel, "Delete Tally Worksheet?")
If iAnswer = vbNo Then GoTo End_Sub
End If
On Error GoTo 0
iAnswer = MsgBox("This procedure will generate a tally worksheet for the worksheet listed in cell L1 of the employees worksheet: " & _
Worksheets("Employees").Range("L1").Value & vbLf & vbLf & _
"Do you wish to continue?", vbYesNo, "Create Tally Sheet?")
If iAnswer = vbYes Then
Worksheets(sWorksheet).Activate
TallyAbsences
Worksheets("Tally " & sWorksheet).Activate
End If
End_Sub:
If bFail Then
Worksheets("Employees").Activate
MsgBox "Cell L1 on the 'Employees' worksheet contains: " & sWorksheet & vbLf & vbLf & _
"Ensure it contains the name (YYYYMMDD) of one of the attendance worksheets and run code again.", , _
"Invalid Attendance Worksheet Specified"
End If
End Sub
Private Sub GenerateWorksheetDates()
'Create a worksheet containing the dates of interest
'Get the date range to include
' if first date in not a Monday, then use the previous Monday
' if last date is not a Friday, the use the following Friday
'
Dim dteStartDate As Date
Dim dteEndDate As Date
Dim sInput As String
Dim sWorksheetName As String
Dim lX As Long
Dim iAnswer As VbMsgBoxResult
Dim lLastDateColumn As Long
Do
sInput = InputBox("What is the first Monday date for the new tracking worksheet? If a Monday date is not entered then Monday prior to the entered date will be used.", "Start Date", Int(Now()))
If sInput = vbNullString Then GoTo End_Sub
Loop While Not IsDate(sInput)
dteStartDate = CDate(sInput)
Do
sInput = InputBox("What is the last date for the new tracking worksheet? If a Friday date is not entered then Friday following the entered date will be used. ", "Start Date", DateSerial(Year(Now()), 12, 31))
If sInput = vbNullString Then GoTo End_Sub
Loop While Not IsDate(sInput)
dteEndDate = CDate(sInput)
'If start date was not a Monday get Monday before date entered
If Weekday(dteStartDate, vbMonday) <> 1 Then
dteStartDate = dteStartDate - Weekday(dteStartDate, vbMonday) + 1
End If
'If end date was not a Friday get Friday after date entered
If Weekday(dteEndDate, vbFriday) <> 1 Then
dteEndDate = dteEndDate + 8 - Weekday(dteEndDate, vbFriday)
End If
sWorksheetName = Format(dteStartDate, "yyyymmdd")
For lX = 1 To Worksheets.Count
If Worksheets(lX).Name = sWorksheetName Then
iAnswer = MsgBox(sWorksheetName & " already exists. Do you want to delete it?", vbYesNo, "Delete Existing Worksheet?")
Exit For
End If
Next
If iAnswer = vbNo Then GoTo End_Sub
If iAnswer = vbYes Then
Application.DisplayAlerts = False
Worksheets(sWorksheetName).Delete
Application.DisplayAlerts = True
End If
Worksheets.Add(After:=Sheets(Sheets.Count)).Name = sWorksheetName
With Worksheets("Employees").Range("L1")
.NumberFormat = "@"
.Value = sWorksheetName
End With
'Add Date
Cells(1, 1).Resize(5, 1).Value = Application.Transpose(Array("Monday", "Tuesday", "Wednesday", "Thursday", "Friday"))
With Range("B1:B5")
.FormulaR1C1 = "=" & CLng(dteStartDate) & "+ Row()-1"
.Value = .Value
.NumberFormat = "mm/dd/yyyy"
End With
Range("B1:ZZ5").DataSeries Rowcol:=xlRows, Type:=xlChronological, Date:=xlDay, _
Step:=7, stop:=CLng(dteEndDate), Trend:=False
Range("A1").CurrentRegion.EntireColumn.AutoFit
'Remove 1st, 3rd, 5th Tuesdays
lLastDateColumn = Cells(1, Columns.Count).End(xlToLeft).Column
For lX = 2 To lLastDateColumn
Select Case Day(Cells(2, lX).Value)
Case 1 To 7, 15 To 21
'Is 1st or 3rd - Do nothing
Case Else
Cells(2, lX).Clear
End Select
Next
End_Sub:
End Sub
Private Sub InsertNames()
'Insert Employee names under appropriate days (include lBlankRowCount rows as well)
Dim lLastEmpNameRow As Long
Dim lX As Long
Dim lDayCount As Long
Dim aryNames As Variant
Dim aryDays(1 To 5) As Variant
Dim lBlankRowCount As Long
lBlankRowCount = 3 '# of blank rows in each day after names are inserted
aryDays(1) = "M": aryDays(2) = "T": aryDays(3) = "W": aryDays(4) = "R": aryDays(5) = "F"
With Worksheets("Employees")
.AutoFilterMode = False
lLastEmpNameRow = .Cells(.Rows.Count, 1).End(xlUp).Row
For lX = 5 To 1 Step -1
.AutoFilterMode = False
.Range("A1").CurrentRegion.AutoFilter Field:=2, Criteria1:="=*" & aryDays(lX) & "*", Operator:=xlAnd
lDayCount = Application.WorksheetFunction.Subtotal(3, .Columns(1)) - 1
If lDayCount > 0 Then
With Worksheets(.Range("L1").Value)
.Rows(lX + 1 & ":" & lX + lDayCount + lBlankRowCount).Insert _
Shift:=xlDown, CopyOrigin:=xlFormatFromRightOrBelow
End With
.Range("A2:A" & lLastEmpNameRow).SpecialCells(xlCellTypeVisible).Copy _
Destination:=Worksheets(.Range("L1").Value).Range("A" & lX + 1)
End If
Next
.AutoFilterMode = False
Worksheets(.Range("L1").Value).UsedRange.Offset(0, 1).Cells.HorizontalAlignment = xlCenter
End With
End Sub
Private Sub FormatDateRows()
Dim aryDays As Variant
Dim lX As Long, lY As Long
Dim oFound As Object
Dim oBFound As Object
Dim lLastColumn As Long
Dim lLastRow As Long
Dim lRefMonth As Long
Dim lTopRow As Long
Dim lBottomRow As Long
Dim lBlankCount As Long
Dim lCurMonth As Long
If Range("A1") <> "Monday" Then
MsgBox "Must be run on a worksheet with 'Monday' in cell A1."
GoTo End_Sub
End If
aryDays = Array("Monday", "Tuesday", "Wednesday", "Thursday", "Friday")
lLastColumn = Cells(1, Columns.Count).End(xlToLeft).Column
For lX = LBound(aryDays) To UBound(aryDays)
Set oFound = Columns("A:A").Find(What:=aryDays(lX), LookIn:=xlFormulas, _
LookAt:=xlWhole, SearchOrder:=xlByColumns, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False)
If Not oFound Is Nothing Then
'Format Dates
With Range(Cells(oFound.Row, 1), Cells(oFound.Row, lLastColumn))
.Font.Bold = True
.Borders(xlDiagonalDown).LineStyle = xlNone
.Borders(xlDiagonalUp).LineStyle = xlNone
.Borders(xlEdgeLeft).LineStyle = xlNone
.Borders(xlEdgeTop).LineStyle = xlNone
With .Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlMedium
End With
.Borders(xlEdgeRight).LineStyle = xlNone
.Borders(xlInsideVertical).LineStyle = xlNone
.Borders(xlInsideHorizontal).LineStyle = xlNone
With .Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorDark1
.TintAndShade = -0.149998474074526
.PatternTintAndShade = 0
End With
End With
End If
Next
'Add Vertical lines for months
lLastRow = Cells(Rows.Count, 1).End(xlUp).Row
For lX = LBound(aryDays) To UBound(aryDays)
Set oFound = Columns("A:A").Find(What:=aryDays(lX), LookIn:=xlFormulas, _
LookAt:=xlWhole, SearchOrder:=xlByColumns, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False)
If Not oFound Is Nothing Then
If oFound.Offset(0, 1) = "" Then 'Blank Tuesday in column B
lRefMonth = Month(CDate(Range("B1").Value + 1))
Else
lRefMonth = Month(Cells(oFound.Row, 2))
End If
lTopRow = oFound.Row
If lX <> UBound(aryDays) Then
Set oBFound = Columns("A:A").Find(What:=aryDays(lX + 1), LookIn:=xlFormulas, _
LookAt:=xlWhole, SearchOrder:=xlByColumns, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False)
If Not oBFound Is Nothing Then
lBottomRow = oBFound.Row - 1
Else
lBottomRow = lLastRow
End If
End If
If lX = LBound(aryDays) Then
lBlankCount = oBFound.Row - 1 - Application.WorksheetFunction.CountA(Range("A2:A" & oBFound.Row))
End If
If lX = UBound(aryDays) Then lBottomRow = lLastRow + lBlankCount
For lY = 2 To lLastColumn
If Cells(oFound.Row, lY) = vbNullString Then
lCurMonth = Month(1 + Cells(oFound.Row, lY).End(xlUp))
Else
lCurMonth = Month(Cells(oFound.Row, lY))
End If
If lCurMonth <> lRefMonth Then
lRefMonth = lCurMonth
With Range(Cells(lTopRow, lY), Cells(lBottomRow, lY))
.Borders(xlDiagonalDown).LineStyle = xlNone
.Borders(xlDiagonalUp).LineStyle = xlNone
With .Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
.Borders(xlEdgeTop).LineStyle = xlNone
.Borders(xlEdgeBottom).LineStyle = xlNone
.Borders(xlEdgeRight).LineStyle = xlNone
.Borders(xlInsideVertical).LineStyle = xlNone
End With
End If
Next
End If
Next
With ActiveSheet.UsedRange
.Columns(1).ColumnWidth = 50
.EntireColumn.AutoFit
.Cells.EntireRow.AutoFit
End With
Set oFound = Nothing
Set oBFound = Nothing
End_Sub:
End Sub
Private Sub TallyAbsences()
'Using the active attendance worksheet
' create tallys on the Employee sheet and copy to new worksheet named for source data
Dim lEmpLastRow As Long
Dim dteToday As Date
Dim lX As Long, lY As Long
Dim lLastCountColumn As Long
Dim aryDays As Variant
Dim oEFound As Object
Dim lLastTallyRow As Long
Dim lDateRow As Long
Dim lDateCount As Long
Dim lPresentCount As Long
Dim lReportColumn As Long
Dim sOutput As String
Dim aryMtgCount As Variant
Dim sEmpMtgDays As String
Dim lDayPos As Long
Dim sWorksheet As String
Dim dteMinDate As Date
Dim dteMaxDate As Date
dteToday = Int(Now())
aryDays = Array("Monday", "Tuesday", "Wednesday", "Thursday", "Friday")
aryMtgCount = Array(0, 0, 0, 0, 0)
sWorksheet = ActiveSheet.Name
If Range("A1") <> "Monday" Then
MsgBox "Must be run on a worksheet with 'Monday' in cell A1."
GoTo End_Sub
End If
On Error Resume Next
Application.DisplayAlerts = False
Worksheets("Tally " & sWorksheet).Delete
Application.DisplayAlerts = True
On Error GoTo 0
aryDays = Array("Monday", "Tuesday", "Wednesday", "Thursday", "Friday")
With Worksheets("Employees")
lEmpLastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
End With
lLastTallyRow = Cells(Rows.Count, 1).End(xlUp).Row
For lX = 1 To lLastTallyRow
If Cells(lX, 1).Value <> vbNullString Then
Select Case Cells(lX, 1).Value
Case "Monday", "Tuesday", "Wednesday", "Thursday", "Friday"
lReportColumn = 3 + (InStr("Monday Tuesday Wednesday Thursday Friday", Cells(lX, 1).Value) - 1) / 10
lLastCountColumn = Cells(lX, Columns.Count).End(xlToLeft).Column
For lY = 2 To lLastCountColumn
If Cells(lX, lY).Value > dteToday Then
lLastCountColumn = lY - 1
Exit For
End If
Next
lDateCount = Application.WorksheetFunction. _
Subtotal(3, Range(Cells(lX, 1), Cells(lX, lLastCountColumn)))
aryMtgCount(lReportColumn - 3) = aryMtgCount(lReportColumn - 3) + (lDateCount - 1)
Case Else
lPresentCount = Application.WorksheetFunction. _
Subtotal(3, Range(Cells(lX, 1), Cells(lX, lLastCountColumn)))
Set oEFound = Worksheets("Employees").Columns("A:A").Find(What:=Cells(lX, 1).Value, _
LookIn:=xlFormulas, LookAt:=xlWhole, SearchOrder:=xlByColumns, _
SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False)
If Not oEFound Is Nothing Then
Worksheets("Employees").Cells(oEFound.Row, lReportColumn).Value = lDateCount - lPresentCount
Else
sOutput = sOutput & Cells(lX, 1).Value & "(" & lX & "), "
End If
End Select
End If
Next
With Worksheets("Employees")
.Range("C1").Resize(1, 8).Value = Array("Mon", "Tue", "Wed", "Thu", "Fri", _
"Mtg" & vbLf & "Missed", "Mtg" & vbLf & "Possible", "% Mtg" & vbLf & "Missed")
'Populate meetings made column
With .Range("H2:H" & lEmpLastRow)
.NumberFormat = "0"
.FormulaR1C1 = "=SUM(RC[-5]:RC[-1])"
.Value = .Value
End With
'Populate total meetings possible column
For lX = 2 To lEmpLastRow
.Cells(lX, "I").Value = 0
sEmpMtgDays = .Cells(lX, 2).Value
For lY = 1 To Len(Trim(sEmpMtgDays))
lDayPos = InStr("MTWRF", Mid(sEmpMtgDays, lY, 1))
If lDayPos > 0 Then
.Cells(lX, "I").Value = .Cells(lX, "I").Value + aryMtgCount(lDayPos - 1)
End If
Next
Next
'Populate % meetings missed column
With .Range("J2:J" & lEmpLastRow)
.NumberFormat = "0.0%"
.FormulaR1C1 = "=RC[-2]/RC[-1]"
.Value = .Value
End With
End With
'Copy to Tally Worksheet
dteMinDate = Application.WorksheetFunction.Min(ActiveSheet.UsedRange)
dteMaxDate = Application.WorksheetFunction.Max(ActiveSheet.UsedRange)
Worksheets.Add(After:=Sheets(ActiveSheet.Index)).Name = "Tally " & sWorksheet
With Worksheets("Employees")
.Range("A1").CurrentRegion.Copy Destination:=Range("A5")
End With
With Worksheets("Tally " & sWorksheet)
.Columns(1).ColumnWidth = 50
.UsedRange.Columns.EntireColumn.AutoFit
.UsedRange.Rows.EntireRow.AutoFit
.Range("A1").Value = "Tally sheet for " & sWorksheet & " as of " & Format(Int(Now()), "mm/dd/yyyy")
.Range("A2").Value = "Minimum Date = " & Format(dteMinDate, "mm/dd/yyyy") & " " & "Maximum Date = " & Format(dteMaxDate, "mm/dd/yyyy")
End With
With Worksheets("Employees")
.Range("C:J").Columns.ClearContents
End With
End_Sub:
Set oEFound = Nothing
End Sub
Function FollowingFriday(dteInput As Date) As Date
'If dteInput is Friday, return dteInput else return Friday after dteInput
If Weekday(dteInput, vbFriday) = 1 Then
FollowingFriday = dteInput
Else
FollowingFriday = dteInput + 8 - Weekday(dteInput, vbFriday)
End If
End Function
