Help with Count if

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!Attachment 17557

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

Code:

---

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

---

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.

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

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

Quote:

---

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

Code:

---

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

---