Counting cell values that contain dates that meet certain criteria-CodePudding

The desired outcome is to count the number of date values in a range that are greater than 24 hours old. The code works; however, it doesn't quite work as desired. In this specific application, there are three dates that are older that 24 hours. See pertinent lines of code commented with the word 'Here'.

My question is I am passing a variable as Date, but does this only include the date when comparing to other date data type and excluding the time (or fractional value), or does the Date include hours as well? My intuition tells me that is only calculating the date (whole serialize number part) and not the fractional part of the serialize number representing the time, which is why the one value doesn't meet the criteria, even though it is indeed older than 24 hours.

To clarify, there are a total of three values that should be returned based on the established criteria: I want the variable cellCounter to evaluate to 3, but is only returning a value of 2, even though there are indeed 3 dates that are older than the 24 hours from the current time/date.

In the Locals Windows, I noticed that the variable todaysDate evaluates to #12:00:00 AM# instead of a date (this variable has no real purpose in the procedure). What am I missing as far as getting the procedure to recognize dates older than 24 hours?

Function ExpiredEscortsListBoxArray() As Variant
'Dimension and assign variables
Dim arrTempList2() As Variant
Dim rowCount As Single, listCounter As Single, cellCounter As Single
Dim i As Single, ri As Single, ci As Single, c As Single
Dim oRow As ListRow, rowi As Single

Dim rowiBlank As Single

Dim it As Variant
Dim currDate As Date 'Here
Dim todaysDate As Date 'Here

Dim wbkVMS As Workbook: Set wbkVMS = ThisWorkbook
Dim wks As Worksheet
Dim lo As ListObject

Set wks = wbkVMS.Worksheets("Visitor Log")
Set lo = wks.ListObjects("tblVisitorLog")

'Initialize variables
cellCounter = 0
i = 0
ri = 0
ci = 0
c = 0
currDate = Date 'Here
currDate = currDate - 1 'Here

'Assign blank cell count to variable. This variable will determine size of dynamic array.
For Each oRow In lo.ListRows
    rowi = rowi   1
    If lo.Range.Cells(rowi   1, 15).Value < currDate And lo.Range.Cells(rowi   1, 16) = "" Then 'Here
    cellCounter = cellCounter   1
    End If
Next

If cellCounter = 0 Then
    ReDim arrTempList2(0, 16)
    arrTempList2(0, 0) = " "
    arrTempList2(0, 1) = "No Expired Escorts"
    arrTempList2(0, 2) = " "
    arrTempList2(0, 3) = " "
    arrTempList2(0, 4) = " "
    arrTempList2(0, 5) = " "
    arrTempList2(0, 6) = " "
    arrTempList2(0, 7) = " "
    arrTempList2(0, 8) = " "
    arrTempList2(0, 9) = " "
    arrTempList2(0, 10) = " "
    arrTempList2(0, 11) = " "
    arrTempList2(0, 12) = " "
    arrTempList2(0, 13) = " "
    arrTempList2(0, 14) = " "
    arrTempList2(0, 15) = " "
    arrTempList2(0, 16) = " "
    ExpiredEscortsListBoxArray = arrTempList2
    GoTo CancelFunction
End If

ReDim arrTempList2(cellCounter - 1, 16)
For listCounter = 1 To lo.ListRows.Count 'Increments based on the total rows on "Visitor Log"
    'Selects the row if the "End" field (14th column) is blank
    If lo.Range.Cells(listCounter   1, 16) = "" Then
        If lo.Range.Cells(listCounter   1, 15).Value < currDate Then 'Here
            ri = ri   1
            For ci = 0 To 16 'Starts inner loop index for the listbox control column
                c = c   1 'Increments the list range column of the "Visitor Log"
                arrTempList2(ri - 1, ci) = lo.Range.Cells(listCounter   1, c).Value
            Next ci
        End If
    End If
    c = 0
Next listCounter
ExpiredEscortsListBoxArray = arrTempList2

CancelFunction:

End Function

CodePudding user response：

Using the DateDiff built-in function will be helpful. Additionally, creating a function that does the time comparison will make it easier to test and 'dial-in' exactly the time measurement you are looking for. The code below is the original code with the addition of an IsMoreThan24Hours function to isolate the comparison functionality.

Public Function ExpiredEscortsListBoxArray() As Variant
'Dimension and assign variables
Dim arrTempList2() As Variant
Dim rowCount As Single, listCounter As Single, cellCounter As Single
Dim i As Single, ri As Single, ci As Single, c As Single
Dim oRow As ListRow, rowi As Single

Dim rowiBlank As Single

Dim it As Variant
Dim currDate As Date 'Here
Dim todaysDate As Date 'Here

Dim wbkVMS As Workbook: Set wbkVMS = ThisWorkbook
Dim wks As Worksheet
Dim lo As ListObject

Set wks = wbkVMS.Worksheets("Visitor Log")
Set lo = wks.ListObjects("tblVisitorLog")

'Initialize variables
cellCounter = 0
i = 0
ri = 0
ci = 0
c = 0
currDate = Date 'Here
currDate = currDate - 1 'Here

Dim currentDateTime As Date
currentDateTime = Now

'Assign blank cell count to variable. This variable will determine size of dynamic array.
For Each oRow In lo.ListRows
    rowi = rowi   1
'******************************
    'If lo.Range.Cells(rowi   1, 15).Value < currDate And lo.Range.Cells(rowi   1, 16) = "" Then 'Here
    If IsMoreThan24Hours(currentDateTime, lo.Range.Cells(rowi   1, 15).Value) And lo.Range.Cells(rowi   1, 16) = "" Then 'Here
        cellCounter = cellCounter   1
    End If
'*******************************
Next

If cellCounter = 0 Then
    ReDim arrTempList2(0, 16)
    arrTempList2(0, 0) = " "
    arrTempList2(0, 1) = "No Expired Escorts"
    arrTempList2(0, 2) = " "
    arrTempList2(0, 3) = " "
    arrTempList2(0, 4) = " "
    arrTempList2(0, 5) = " "
    arrTempList2(0, 6) = " "
    arrTempList2(0, 7) = " "
    arrTempList2(0, 8) = " "
    arrTempList2(0, 9) = " "
    arrTempList2(0, 10) = " "
    arrTempList2(0, 11) = " "
    arrTempList2(0, 12) = " "
    arrTempList2(0, 13) = " "
    arrTempList2(0, 14) = " "
    arrTempList2(0, 15) = " "
    arrTempList2(0, 16) = " "
    ExpiredEscortsListBoxArray = arrTempList2
    GoTo CancelFunction
End If

ReDim arrTempList2(cellCounter - 1, 16)
For listCounter = 1 To lo.ListRows.Count 'Increments based on the total rows on "Visitor Log"
    'Selects the row if the "End" field (14th column) is blank
    If lo.Range.Cells(listCounter   1, 16) = "" Then
    
'******************************
        'If lo.Range.Cells(listCounter   1, 15).Value < currDate Then 'Here
        If IsMoreThan24Hours(currentDateTime, lo.Range.Cells(listCounter   1, 15).Value) Then 'Here
            ri = ri   1
            For ci = 0 To 16 'Starts inner loop index for the listbox control column
                c = c   1 'Increments the list range column of the "Visitor Log"
                arrTempList2(ri - 1, ci) = lo.Range.Cells(listCounter   1, c).Value
            Next ci
        End If
'******************************
    End If
    c = 0
Next listCounter
ExpiredEscortsListBoxArray = arrTempList2

CancelFunction:

End Function

Private Function IsMoreThan24Hours(ByVal currentDateTime As Date, ByVal dateTimeToCheck As Variant) As Boolean
    Dim diffHours As Variant
    diffHours = DateDiff("h", currentDateTime, dateTimeToCheck)
    
    IsMoreThan24Hours = diffHours <= -24
End Function