Specific range date on this code

Guys please i need help,
How can i put specific date range on this code to show and the counter and specific sub lines i choose and the range date i want?

Code:

---


Sub EmailCounting()
  Dim olApp As Outlook.Application
 Dim olNs As Outlook.Namespace
 Dim olFldr As Outlook.MAPIFolder
 Dim olMailItem As Outlook.MailItem
 Dim olItem As Object
 Dim dic As Dictionary
 Dim i As Long
 Dim Subject As String
 Dim SoughtWord As String
 Dim TheDate As Date
 Dim SoughtWord1 As String

  Set olApp = New Outlook.Application
 Set olNs = olApp.GetNamespace("MAPI")
 Set olFldr = olNs.GetDefaultFolder(olFolderInbox).Folders("Icinga")
 Set dic = New Dictionary  SoughtWord = "CRITICAL"

 TheDate = InputBox("Enter a date")
 Soughtword1= "OK"

  For Each olItem In olFldr.Items
    If olItem.Class = olMail Then
        Subject = olItem.Subject
       
      If InStr(1, Subject, SoughtWord, vbTextCompare) > 0  Or InStr(1, Subject, SoughtWord1, vbTextCompare) > 0 Then
            If dic.Exists(Subject) Then
                    dic(Subject) = dic(Subject) + 1
            Else
                    dic(Subject) = 1
            End If
        End If
 Next olItem

  With ActiveSheet  .Columns("A:C")
    .Clear
    .Range("A1:C1").Value = Array("Count", "Subject", "Date")

    For i = 0 To dic.Count - 1
        .Cells(i + 2, "A") = dic.Items()(i)
        .Cells(i + 2, "B") = dic.Keys()(i)
        .Cells(i + 2, "C") = Date
    Next
 End With

 End Sub

---

This is the code