Count rows that only have date values and are all are greater than current date

Question

I have an Excel table with dates and other values. I need to find the rows that only have dates and where the dates are older than the current date.

Let's say the current date is 23.03.2022, all dates in that row need to be older and there needs to be dates only in the row.

I need to find how many rows there are and put that number into a certain cell.

Example chart

The output should be one row with dates older than the current date because the other rows either have at least one future date, at least one empty cell or cells that contain something other than a date.

I tried Excel functions and I also tried to make separate charts es sub steps for the functions.

Answer 1

Count Date Rows UDF

• Counts the number of rows of a range where all cells contain a date earlier than a given date.

• If no given date, today's date is used.

• If a cell in a row contains anything that is not a date, it is 'disqualified'.

• In Excel use (according to the posted image)

  =CountDateRows(B2:D4)
  =CountDateRows(B2:D4,DATE(2022,3,22))
  =CountDateRows(Sheet2!B2:D4,DATE(2022,3,22))
  =CountDateRows(Sheet2!B2:D4,A1) ' A1 contains a date
  

The Code in a Standard Module, e.g. Module1

Option Explicit

Function CountDateRows( _
    ByVal rg As Range, _
    Optional ByVal InitialDate As Variant) _
As Long
    
    If IsMissing(InitialDate) Then InitialDate = Date
    
    Dim rCount As Long: rCount = rg.Rows.Count
    Dim cCount As Long: cCount = rg.Columns.Count
    
    Dim Data As Variant
    
    If rCount + cCount = 2 Then
        ReDim Data(1 To 1, 1 To 1): Data(1, 1).Value = rg.Value
    Else
        Data = rg.Value
    End If
    
    Dim cValue As Variant
    Dim r As Long
    Dim c As Long
    Dim fCount As Long ' Number of Found Rows
    Dim IsOk As Boolean
    
    For r = 1 To rCount
        For c = 1 To cCount
            cValue = Data(r, c)
            If IsDate(cValue) Then
                If cValue < InitialDate Then IsOk = True
            End If
            If IsOk Then IsOk = False Else Exit For
        Next c
        If c > cCount Then fCount = fCount + 1
    Next r
    
    CountDateRows = fCount
    
End Function