How to export Outlook email details to Excel by selecting a date range?

Question

I managed to write VBA code that exports Outlook email details to Excel. I am stuck writing code to export the data based on date range.

Sub getMailbyDate()
    Dim i As Long
    Dim arrHeader As Variant
    
    Dim olNS As Namespace
    Dim olInboxFolder As MAPIFolder
    Dim olItems As Items
    Dim olItem As Variant
    
    Set olNS = GetNamespace("MAPI")
    Set olInboxFolder = olNS.PickFolder 'Pick folder
    Set olItems = olInboxFolder.Items

    Dim StartDate As Date, EndDate As Date
    
    arrHeader = Array("Date Created", "SenderEmailAddress", "Subject", "Body")
    ThisWorkbook.Worksheets("Output").Range("A1").Resize(1, UBound(arrHeader) + 1).Value = arrHeader
    
    ActiveSheet.Range("E2", Range("E2").End(xlDown)).NumberFormat = "mm/dd/yyyy h:mm AM/PM"
    
    i = 1
    
    rngA = ThisWorkbook.Worksheets(1).Range("B7").Value
    rngB = ThisWorkbook.Worksheets(1).Range("B8").Value
  
    StartDate = DateValue(rngA)
    EndDate = DateValue(rngB)
    
    For Each olItem In olItems
        ' MailItem
        If olItem.Class = olMail Then
            If olItem.SentOn >= StartDate And olItem.SentOn <= EndDate Then
            ThisWorkbook.Worksheets("Output").Cells(i + 1, "A").Value = olItems(i).CreationTime
            ThisWorkbook.Worksheets("Output").Cells(i + 1, "B").Value = olItems(i).SenderEmailAddress
            ThisWorkbook.Worksheets("Output").Cells(i + 1, "C").Value = olItems(i).Subject
            ThisWorkbook.Worksheets("Output").Cells(i + 1, "D").Value = olItems(i).Body
            End If
        ' ReportItem
        ElseIf olItem.Class = olReport Then
            ThisWorkbook.Worksheets("Output").Cells(i + 1, "A").Value = olItems(i).CreationTime
            ThisWorkbook.Worksheets("Output").Cells(i + 1, "B").Value = _
            olItems(i).PropertyAccessor.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x0E04001E")  'PR_DISPLAY_TO
            ThisWorkbook.Worksheets("Output").Cells(i + 1, "C").Value = olItems(i).Subject
        End If
        
        i = i + 1
    Next olItem
    
    ThisWorkbook.Worksheets(3).Cells.EntireColumn.AutoFit
    
    MsgBox "Export complete.", vbInformation
           
    Set olItems = Nothing
    Set olInboxFolder = Nothing
    Set olNS = Nothing
End Sub

I would like to export the date either by writing the date on the input box, or by writing a date range in Sheet 1.
After I export the emails I would like to filter the data in Column D (sheet 3) by a range of keywords in Sheet 2 Column A. It seems that the autofilter that I used filters data that equals the keywords in Sheet 2. I need to filter by "contains".

Sub filter()
Set sourceTemplate = ActiveWorkbook.ActiveSheet
LastRow = sourceTemplate.Cells(sourceTemplate.Rows.Count, "A").End(xlUp).Row
Dim vCrit As Variant
Dim wsOutput As Worksheet
Dim wsRules As Worksheet
Dim rngCrit As Range
Dim rngOutput As Range

Set wsOutput = Worksheets("Output")
Set wsRules = Worksheets("Rules")
Set rngOutput = wsOutput.Range("$A$1").CurrentRegion
Set rngCrit = wsRules.Range("A2:A" & LastRow)

' If filter matches criteria, write in column E "Out of the office"

vCrit = rngCrit.Value

rngOutput.AutoFilter _
    Field:=3, _
    Criteria1:=Application.Transpose(vCrit), _
    Operator:=xlFilterValues
   
End Sub

How have you defined StartDate and EndDate and what are their values? If If olItem.Class = olMail And olItem.SentOn >= SinceDate Then worked for you then what I suggested should work for you if they are valid dates. — Siddharth Rout
Dim StartDate As Date Dim EndDate As Date StartDate = Format(ThisWorkbook.Worksheets(1).Range("B7").Value, "mm/dd/yyyy") EndDate = Format(ThisWorkbook.Worksheets(1).Range("B8").Value, "mm/dd/yyyy") For Each olItem In olItems ' MailItem If olItem.Class = olMail And olItem.SentOn >= StartDate And olItem.SentOn <= EndDate Then — Tardox
No No... Format() is not converitng it into date but a string. You need to convert it into a date like you did in DateValue(inpSinceDate$) — Siddharth Rout

Siddharth Rout Siddharth Rout · Accepted Answer · 2020-09-03T09:53:36

Is this what you are trying? As I mentioned in the comment above you need to split up the IFs because .SentOn will give an error for the report item.

'
'~~> Rest of your code
'

Dim StartDate As Date, EndDate As Date

'~~> rngA and rngB are relevant ranges
StartDate = DateValue(rngA.Value2)
EndDate = DateValue(rngB.Value2)

For Each olItem In olItems
    If olItem.Class = olMail Then
        If olItem.SentOn >= StartDate And olItem.SentOn <= EndDate Then
            '~~> Rest of your code

            i = i + 1
        End If
    ElseIf olItem.Class = olReport Then
        '~~> Rest of your code

         i = i + 1
    End If
Next olItem

'
'~~> Rest of your code
'

How to export Outlook email details to Excel by selecting a date range?

1 Answers