Create a subfolder and move filtered mails based on two date range in outlook using vba

 Sub createfolderandmovemail()
Dim olApp, mail, fldr As Object
Set olApp = CreateObject("Outlook.Application")
Dim olFolder As Outlook.MAPIFolder
Dim olmailitem As Outlook.MailItem
Dim count As Integer
Dim xDate As Date
Dim DateStart As Date
Dim DateEnd As Date
'get date 1 day back
DateStart = Date - 1
'get todays date

DateEnd = Date

Dim datetocheck As String

'MsgBox (xDate)
count = 0
Set olFolder = olApp.GetNamespace("MAPI").Folders("allsourav@gmail.com")
'If (olFolder.Folders.count > 0) Then
'    For Each Folder In olFolder.Folders
'        MsgBox (Folder.Name)
'
'    Next
'End If
'Set olFolder = olApp.GetNamespace("MAPI").Folders("allsourav@gmail.com").Folders("[Gmail]")
Set olFolder = olApp.GetNamespace("MAPI").Folders("allsourav@gmail.com").Folders("Inbox")

'lets try to access test under inbox

On Error Resume Next
Set fldr = olFolder.Folders("test")

'if test does not exist

If fldr Is Nothing Then
Set fldr = olFolder.Folders.Add("test")
End If

On Error GoTo 0


'If (olFolder.Folders.count > 0) Then
'    For Each Folder In olFolder.Folders
'        MsgBox (Folder.Name)
'
'    Next
'End If
'Set olFolder = olFolder.Folders("Inbox")



'numeral
'Set itmemail = filteredList.Find("[Importance]=2") 'mail with high importance
'we can use a variable like this
'strFind = "[Importance]=2"

'boolean
'strFind = "[UnRead]=False"

'search by date and time

datetocheck = "[ReceivedTime] >= '" & Format(DateStart, "ddddd h:nn AMPM") & "' And [ReceivedTime] <= '" & Format(DateEnd, "ddddd h:nn AMPM") & "'"
MsgBox (datetocheck)

'For Each i In olFolder.Items.Restrict(datetocheck)
'
'    ' If the email is an Outlook email
'        If i.Class = olMail Then
'
'            Set mi = i
'                UserForm1.Show
'            ' If there are more than 0 attachments, ie, if it finds an attachment
'                If mi.Attachments.count > 0 Then
'
'
'                    For Each at In mi.Attachments
'                    'Debug.Print mi.SenderName & " " & mi.ReceivedTime ' <- uncomment this part if you need to debug (remember to open the "immediate" window also
'                        ' Look for attachments that contain ".xls" (this will also pick up ".xlsx" and ".xlsm" etc
'                        If InStr(LCase(at.Filename), ".xls") > 0 Then
'                            ' Tell the script where to save the file and what details need to be appeneded to the file name to make it a unique name
'                            at.SaveAsFile "\\xxxx\xxxxx\xxxxx\" & Format(mi.ReceivedTime, "yyyy-mm-dd hh-nn-ss") & at.Filename
'
'                        Else
'
'                        ' literally do nothing (it's probably not needed but added just in case)
'
'                        End If
'
'
'                    Next at
'
'                End If
'
'        End If
'    Next i

MsgBox (olFolder.Items.Restrict(datetocheck).count)

For i = olFolder.Items.Restrict(datetocheck).count To 1 Step -1


    ' If the email is an Outlook email
        If olFolder.Items.Restrict(datetocheck).Item(i).Class = 43 Then

           'Debug.Print i.Subject, i.SenderName, i.ReceivedTime
           olFolder.Items.Restrict(datetocheck).Item(i).Move fldr
           
        End If
    Next i
End Sub