Specific range date on a code with counting subjects

[antokout]

Hi
I have a code with counting specific subjects emails from outlook and copy to excel.
I need to copy the same specific subject emails but with specific date range for example before 7 days
I would appreciate any help
Thank you

 

[antokout]

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

Guys please help how can i amend this with specific date range too?
Appreciate any help