Функция Now

Sub Data1()
 
With Sheets("Лист7")
    lRow = .Cells(Rows.Count, "F").End(xlUp).Row
    Set R1 = .Range("B2:F" & lRow)
    Set R2 = .Range("F2:F" & lRow)
    arrVal = R2.Value
    arrVal1 = R1.Value
 
 
           With CreateObject("Scripting.Dictionary")
              For Each CL In R2
                L = .Item(CStr(CL.Value))
              Next
              ReDim Arr(1 To .Count, 1 To 2)
              For i = 0 To .Count - 1
                Arr(i + 1, 1) = .keys()(i)
                Counter = 0
                  For j = 1 To UBound(arrVal)
                    If arrVal(j, 1) = .keys()(i) Then
                      If DateValue(arrVal1(j, 1)) = DateValue(Now()) Then
                        Counter = Counter + 1
                      End If
                    End If
                   Next
                 Arr(i + 1, 2) = Counter
              Next
            End With
 
End With
 
Sheets("Лист3").Range("A1").Resize(UBound(Arr), 2).Value = Arr
 
End Sub