No of records for each person 90 days old

[danesrood]

Hi

I have something like 5000 records on a worksheet containing numerous columns but the ones that I am interested in are a staff number in column K and a date in column H.

What I would like to calculate is the number of records for each staff number that are 90 or more working days (not Saturday or Sunday) old from today.

Your help would be much appreciated

[SamT]

Each Staff number has more than one record, so you need more than one count.

Do you have a separate list of unique staff numbers where the counts can be recorded? Will we need to create this list?

What about holidays?

Please provide full details of the desired result.

[danesrood]

Hi Sam

I'm sorry that I didn't explain it to we'll.

Yes there is a separate list of the staff numbers that at the moment will be a couple of columns to the right and there will be quite a few records for each member of staff.
All that I'm looking for is the number of cases that they have had for 90 working days or more. I don't think that there is a need to worry about holidays.

I hope that makes sense.

My thanks for taking an interest.

[SamT]

So Column M is a list of unique staff numbers and we can record the Count of records for each staff in column N next to the relevant staff number.

As we search thru K for old dates, we'll be adding up the values in Column N next to the number in M that corresponds to the matching number in H.

[danesrood]

Hi Sam

Yes M contains a unique list of the staff numbers and the count goes in N

However you have got the wrong columns for the data columns to be checked.

H is the column for the dates and column K contains the staff numbers.

Regards from England

[SamT]

Yes M contains a unique list of the staff numbers and the count goes in N

Lucky guess on my part about the missing details.

BTW, I have been working on the 90 work days in my spare time. However if holidays aren't critical then why not just use 18 weeks ago?

~ 90 workdays ago (18 weeks) = Date - 126

If you can live with counting records older than exactly 18 weeks, this sub should work

Option Explicit

Sub Count90DayOldRecords()
Dim CutoffDate As Date
Dim RecordDate As Date
Dim RecordDates As Range
Dim Sht As Worksheet
Dim StaffNumbers As Range
Dim Cel As Range
Dim LastCel As Range
Dim Found As Range
Dim Answer As Long

Set Sht = Sheets("Sheet1") 'Edit Sheet1 to name of actual worksheet

With Sht
  Set LastCel = .Cells(Rows.Count, "H").End(xlUp)
  Set RecordDates = Range(.Range("H2"), LastCel) 'Assumes headers in Row 1. Edit if needed.

  Set LastCel = .Cells(Rows.Count, "M").End(xlUp)
  Set StaffNumbers = Range(.Range("M2"), LastCel)'Assumes headers in Row 1. Edit if needed.

  Set LastCel = Nothing
  
  CutoffDate = DateAdd("D", -126, Date)
  
  '''' Clear previous counts
  For Each Cel In StaffNumbers
    Cel.Offset(0, 1).ClearContents
  Next Cel
    
  ''''Start Counting
  For Each Cel In RecordDates
    If CDate(Cel.Value) < CutoffDate Then
      ''''Check if valid staff number
      Set Found = StaffNumbers.Find(What:=Cel.Offset(0, 3).Value, After:=.Range("M1")) 'Assumes headers in Row 1. Edit if needed.
      If Found Is Nothing Then 'Invalid number
        Answer = MsgBox("Staff Number " & Cel.Offset(0, 3) & " not found." & vbCr _
          & "Press Yes to continue counting. Press No to stop counting and retry later.")
        If Answer = vbNo Then
          Exit Sub
        Else 'Continue with counting
          GoTo LoopNext
        End If
      Else 'Increment count for this staff number
        With Found
          .Offset(0, 1).Value = .Offset(0, 1).Value + 1
        End With
      End If
    End If
LoopNext:
  Next Cel
      
End With 'Sht
End Sub

[danesrood]

Sam

I've tried the code and it breaks down at this line with the Run Time error 13 Type Mismatch

Set Found = StaffNumbers.Find(What:=Cel.Offset(0, 3).Value, After:=.Range("M1")) 'Assumes headers in Row 1. Edit if needed.

Just to confirm that column M has numbers like 10019344 and H has dates like 13/08/2014 02:18

[SamT]

Remote troubleshooting is time consuming. Lets start with replacing these two lines

            If CDate(Cel.Value) < CutoffDate Then 
                 ''''Check if valid staff number

With these two

            If DateDiff("d", Cel, Date) > 126 Then 
                 ''''Check if valid staff number

BTW, if Cel is in Column H, then, Cel.Offset(0, 3) refers to column K

[danesrood]

Sam

No change I'm afraid stlll Run Time error 13 Type mismatch at the same line.

Confirmation of the layout:

Sheet Name "Sheet1"
Header in row1
Columns A to K contain data at present down to row 5000
H = dates in the format dd/mm/hhhh hh:mm
K = Staff number against each record like 67387303
L is a blank column
M = Unique list of the individual staff numbers like 67387303
N is where I would like the results shown

My sincere thanks for taking the time which is much appreciated

[SamT]

Select Columns K and M at the same time and Format Cells on them to General or Text, then Format their Horizontal Alignment as desired, then insure that Merge Cells and Wrap Text are OFF. Note that formatting them to Text may crash some other Procedure (macro) due to it being too specific. If so, we'll work on that peculiarity

If that doesn't work then change

Set Found = StaffNumbers.Find(What:=Cel.Offset(0, 3).Value, After:=.Range("M1")) 'Assumes headers in Row 1. Edit if needed.

To

Set Found = StaffNumbers.Find(What:=Trim(Cel.Offset(0, 3)), After:=.Range("M1")

[danesrood]

Sam

No joy I'm afraid.

I've changed the Format without success and I then replaced the line of code as suggested but this turned the line red and came up with Compiler Error Syntax Error

[SamT]

Please paste the code from your workbook for us to look at.

[p45cal]

You could try a pivot table.
In the attached is a table with column H having dates 90 days ago from today plus or minus 10 days. There's conditional formatting in that column to highlight dates > 90 days ago (this is only for checking results using the autofilter). There are some staff numbers in column K. There's a pivot table in the vicinity of cell M41. Currently it's filtered on mydates for before 3rd jul 2015. Currently pivot shows only staff numbers which have dates older than 3rd jul 2015 but this can be changed to show all staff numbers leaving blank the count if they don't have any dates older than that. The pivot takes care of creating a unique staff number list. It can be sorted by count if needed.

I've just noticed it's 90 working days. I'm not going to change anything in the workbook - you get the principle. I've added a calculation at cell O3 which shows 90 working days ago, so you'd use this date in filtering the pivot table on mydate instead of 3rd jul 2015.

[danesrood]

Sam

Here is the latest code after making the changes that you suggested. I confirm that I have changed the format for columns K & M to Text and that there are no merged cells or Word Wrap
The latest code change that you suggested comes up red with the message compile error syntax error.
Option Explicit

Sub Count90DayOldRecords()
    Dim CutoffDate As Date
    Dim RecordDate As Date
    Dim RecordDates As Range
    Dim Sht As Worksheet
    Dim StaffNumbers As Range
    Dim Cel As Range
    Dim LastCel As Range
    Dim Found As Range
    Dim Answer As Long
     
    Set Sht = Sheets("Sheet1") 'Edit Sheet1 to name of actual worksheet
     
    With Sht
        Set LastCel = .Cells(Rows.Count, "H").End(xlUp)
        Set RecordDates = Range(.Range("H2"), LastCel) 'Assumes headers in Row 1. Edit if needed.
         
        Set LastCel = .Cells(Rows.Count, "M").End(xlUp)
        Set StaffNumbers = Range(.Range("M2"), LastCel) 'Assumes headers in Row 1. Edit if needed.
         
        Set LastCel = Nothing
         
        CutoffDate = DateAdd("D", -126, Date)
         
         '''' Clear previous counts
        For Each Cel In StaffNumbers
            Cel.Offset(0, 1).ClearContents
        Next Cel
         
         ''''Start Counting
        For Each Cel In RecordDates
            'If CDate(Cel.Value) < CutoffDate Then
            '     ''''Check if valid staff number
            'replaced previous two
            If DateDiff("d", Cel, Date) > 126 Then
     ''''Check if valid staff number
               ' Set Found = StaffNumbers.Find(What:=Cel.Offset(0, 3).Value, After:=.Range("M1")) 'Assumes headers in Row 1. Edit if needed.
               'replaced with
               Set Found = StaffNumbers.Find(What:=Trim(Cel.Offset(0, 3)), After:=.Range("M1")
                If Found Is Nothing Then 'Invalid number
                    Answer = MsgBox("Staff Number " & Cel.Offset(0, 3) & " not found." & vbCr _
                    & "Press Yes to continue counting. Press No to stop counting and retry later.")
                    If Answer = vbNo Then
                        Exit Sub
                    Else 'Continue with counting
                        GoTo LoopNext
                    End If
                Else 'Increment count for this staff number
                    With Found
                        .Offset(0, 1).Value = .Offset(0, 1).Value + 1
                    End With
                End If
            End If
LoopNext:
        Next Cel
         
    End With 'Sht
End Sub

[SamT]

Missing the final ")" in

Set Found = StaffNumbers.Find(What:=Trim(Cel.Offset(0, 3)), After:=.Range("M1"))

[danesrood]

Hi Sam

That just brings us back to Run Time Error 13 Type Mismatch.

[p45cal]

Take out the:
After:=.Range("M1")
altogether; M1 is outside the StaffNumbers range anyway.

If that still doesn't solve it then consider setting some of the other arguments on that line.
Range.Find remembers some of those arguments (whether set by vba or the user using Find manually on the sheet). Specifically, from Help:
"The settings for LookIn, LookAt, SearchOrder, and MatchByte are saved each time you use this method. If you do not specify values for these arguments the next time you call the method, the saved values are used. Setting these arguments changes the settings in the Find dialog box, and changing the settings in the Find dialog box changes the saved values that are used if you omit the arguments. To avoid problems, set these arguments explicitly each time you use this method."

Don't worry about MatchByte but what isn't mentioned is that SearhFormat should also be set to False:
SearchFormat:=False