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

[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