count blank cells based on row and column range criteria

[junglerose]

A	B	C	D	E
	3/31/2014	4/7/2014	4/14/2014	5/12/2014
Amy	x
Bill	x	x
Tom			x
	4/2/2014	4/9/2014	4/16/2014	5/16/2014
Amy		x

<tbody>
</tbody>

I'm trying to count missed attendance based on the person's name (column a) and a range of dates (rows 1 and 6) before today. So I want to count the blank cells in all the rows that say "Amy" that fall on a date before today (so even though E2 is blank, I don't want to count it). There are different groups of people who have to meet on different days so I wanted to have one master worksheet that calculated how many meetings each person has missed. One person may have to go to multiple meetings during the week which is why their name comes up twice. Is there a formula that can search for a name, figure out if cells in the row are blank AND before today and then count them. Or do I have to make a different worksheet for every group of dates? Thanks for any help or advice anyone can offer.

 

[pbornemeier]

Create a workbook that has 1 worksheet in it named 'Employees'. Column A contains unique names for each employee, column B contains concatenated single letter abbreviations that represent the days that the employee is supposed to attend a meeting. MTWRF (R = Thursday)

Run 'CreateInputWorksheet' it will ask for a range of dates and create the input worksheets (named in a YYYYMMDD format that represents the first date).

Run 'UpdateTallySheet' to generate an absence report on the worksheet whose YYYYMMDD names appears in cell L1 of the 'Employees' worksheet.

Let me know how it works for you

Excel Workbook
	A	B
1	Name	Required
2	Amy	WR
3	Angela	MW
4	Bob	WR
5	Claire	W
6	Elizabeth	WF
7	Henry	W
8	James	WF
9	Jennifer	T
10	Julia	TWR
11	Karissa	MW
12	Kelly	MTW
13	Kyle	WF
14	Lacy	MTW
15	Leslie	MW
16	Mark	MTW
17	Nicole	W
18	Robert	MW
19	Robin	WR
20	Sandy	T
21	Scott	WF
22	Spenser	W
23	Stephanie A	WR
24	Stephanie B	WF
25	Steven	WF
Employees

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