Help with Count if

[mcal45usn]

Hello,

I was able to get great help with keeping a running tally on individuals who call in each day. I uploaded a copy and someone did a great job( i uploaded it again so you can see, and see what im looking to do). I have a master list of individuals on hte first page. Aside from the different sheets I have keeping track of call ins for each day. i want a tracker next to each name on the master list also. can someone give me some advice? Ive tried using countif but im doing something wrong. Thank you!Dispatch Absentee Nov 2016.xlsm

[Paul_Hossler]

I just put the current total in col B of the individuals

Option Explicit
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
    Dim rABS As Range
    Dim sName As String
    Dim dCount As Long, iWS As Long, iToday As Long, iName As Long
    Dim ws As Worksheet
    If Sh.Name = "Individuals" Then Exit Sub
    If Intersect(Target, Sh.Range("A:A")) Is Nothing Then Exit Sub
    
    sName = Target.Cells(1, 1).Value
    If Len(sName) = 0 Then      '   cleared the name cell
        Target.Cells(1, 2).ClearContents
        Exit Sub
    End If
    
    iToday = InStr(Sh.Name, " ")
    iToday = CLng(Right(Sh.Name, Len(Sh.Name) - iToday))
    
    dCount = 1
    
    Application.ScreenUpdating = False
    For iWS = 1 To iToday - 1
        Set ws = Worksheets("Day " & Format(iWS, "##")) '   Day  5 had extra space
        Set rABS = Range(ws.Cells(6, 1), ws.Cells(Sh.Rows.Count, 1).End(xlUp)).Resize(, 2)
    
        dCount = dCount + Application.WorksheetFunction.CountIf(rABS.Columns(1), sName)
    Next iWS
    
    Application.EnableEvents = False
    Target.Cells(1, 2).Value = dCount
    
    With Worksheets("Individuals")
        iName = -1
        On Error Resume Next
        iName = Application.WorksheetFunction.Match(sName, .Columns(1), 0)
        On Error GoTo 0
        
        If iName <> -1 Then
            .Cells(iName, 2).Value = dCount
        End If
    End With
    
    Application.EnableEvents = True
    Application.ScreenUpdating = True
End Sub

[mcal45usn]

Thank you, This is exactly what I want, but for some reason, only 2 names have number next to it, there should be a few more. Is there something I need to do? Im probably doing something wrong.

[Paul_Hossler]

The 'Master' only gets updated when the 'Day N' worksheet is changed since it's faster to just do the one day/one name that changed than all days/all names

The new code only had a few names added mid-month for testing

I can change it to always sweep the 1-to-31 sheets, but I think a 'Force Update' manually run macro would be better

Actually, I was thinking that you probably wanted a 'Clear Data' macro, and some formatting and some cell locking to prevent misplaced inputs

Let me know

[mcal45usn]

Gotchya thank you again for all your help! What would clear data macro do?

[Paul_Hossler]

What would clear data macro do?

Short answer = Clear the Data on each Day-N sheet in cols ABCEGI

Also protects cells, adds data validation, some formatting

Option Explicit
Sub UnprotectAll()
    Dim i As Long
    
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    For i = 1 To 31
        Worksheets("Day " & i).Unprotect
    Next i
End Sub

Sub ForceUpdate()
    Dim rAllNames As Range, rNames As Range, rName As Range
    Dim ws As Worksheet
    Dim i As Long, iName As Long
    
    If MsgBox("Force an Update of Statistics?", vbYesNo + vbQuestion + vbDefaultButton2, "Force Update") = vbNo Then
        Exit Sub
    End If
    
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Set rAllNames = Worksheets("Individuals").Range("A2")
    Set rAllNames = Range(rAllNames, rAllNames.End(xlDown))
    Set rAllNames = rAllNames.Resize(rAllNames.Rows.Count, 2)
    For i = 31 To 1 Step -1
        With Worksheets("Day " & i)
            
            If Len(.Range("A6").Value) = 0 Then GoTo NextDay
            
            Set rNames = .Range("A6")
            Set rNames = Range(rNames, .Cells(.Rows.Count, 1).End(xlUp))
            
            For Each rName In rNames.Rows
                iName = -1
                On Error Resume Next
                iName = Application.WorksheetFunction.Match(rName.Cells(1, 1).Value, rAllNames.Columns(1), 0)
                On Error GoTo 0
            
                If iName <> -1 Then
                    If Len(rAllNames.Cells(iName, 2).Value) = 0 Then
                        rAllNames.Cells(iName, 2).Value = rName.Cells(1, 2).Value
                    End If
                End If
            Next
        End With
            
NextDay:
    Next i
End Sub
 

Sub ClearAndReset()
    Dim rNames As Range
    Dim ws As Worksheet
    Dim i As Long
    
    If MsgBox("Clear Data and Reset Formats?", vbYesNo + vbQuestion + vbDefaultButton2, "Clear Data") = vbNo Then
        Exit Sub
    End If
    
    
    Set rNames = Worksheets("Individuals").Range("A2")
    Set rNames = Range(rNames, rNames.End(xlDown))
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    For i = 1 To 31
    
        rNames.Offset(, 1).ClearContents
    
        With Worksheets("Day " & i)
            
            .Select
            .Unprotect
            
            
            .Rows("6:6").Select
            ActiveWindow.FreezePanes = False
            ActiveWindow.FreezePanes = True
            
            Application.CutCopyMode = False
            
            
            .Cells.Locked = True
            .Range("A3").Locked = False
            .Range("A6:A44").Locked = False
            .Range("C6:C44").Locked = False
            .Range("E6:E44").Locked = False
            .Range("G6:G44").Locked = False
            .Range("I6:I44").Locked = False
            
            .Range("A6:A44").ClearContents
            .Range("B6:B44").ClearContents
            .Range("C6:C44").ClearContents
            .Range("E6:E44").ClearContents
            .Range("G6:G44").ClearContents
            .Range("I6:I44").ClearContents
            
            .Columns("M:XFD").Hidden = True
            With .Range("A6:A44").Validation
                .Delete
                .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:=xlBetween, _
                    Formula1:="=" & rNames.Parent.Name & "!" & rNames.Address(True, True)
                .IgnoreBlank = True
                
                .InCellDropdown = True
                .InputTitle = ""
                .ErrorTitle = ""
                .InputMessage = ""
                .ErrorMessage = ""
                .ShowInput = True
                .ShowError = True
            End With
        
            .Protect DrawingObjects:=True, Contents:=True, Scenarios:=True, UserInterfaceOnly:=True
            .EnableSelection = xlUnlockedCells
        
        End With
    Next i
    Worksheets("Day 1").Select
    Application.EnableEvents = True
    Application.ScreenUpdating = True

End Sub