Import Outlook emails to Excel for specified Date Range

Question

I am trying to make an excel macro to import emails from my outlook folder into an excel file for a specified date range (for received emails). This process has to be done on a regular basis. Hence, I need to go on adding the emails below the existing emails in the excel sheet.

I got that to work, however, my date range does not seem to work. If I add only 'From date', it works and imports all the emails from the specified 'From date' until the last received email. But if I specify a range of dates, then the macro doesn't work at all, although it does not show any error/ debug. It just gives me the message that the import is done. In my sheet cell L1 contains 'From date' and cell L2 contains 'To date'.

How can I correct this?

Sub Download_Emails()

Application.ScreenUpdating = False

Dim OutlookApp As Outlook.Application
Dim OutlookNamespace As Namespace
Dim Folder As MAPIFolder
Dim OutlookMail As Variant
Dim objOwner As Outlook.Recipient
Dim i As Integer
Dim olItems As Object
Dim olItem As Object
Dim LastRow As Long

LastRow = Cells(Rows.Count, "A").End(xlUp).Row

Set OutlookApp = New Outlook.Application
Set OutlookNamespace = OutlookApp.GetNamespace("MAPI")
Set objOwner = OutlookNamespace.CreateRecipient("xxxxx.com")   
objOwner.Resolve

'Allows the user to select the desired folder from which the emails are to be imported
If objOwner.Resolved Then
Set Folder = GetObject("", "Outlook.Application").GetNamespace("MAPI").PickFolder
End If

i = LastRow
LastRow = LastRow + 1

For Each OutlookMail In Folder.Items
If TypeName(OutlookMail) = "MailItem" Then

'Sets the date from which the user wants to import the emails from
If CDate(OutlookMail.ReceivedTime) >= Range("L1").Value And CDate(OutlookMail.ReceivedTime) <= Range("L2").Value Then

'Imports email subject, received date and time, sender's name, and the email body into the excel file
Range("A1").Offset(i, 0) = OutlookMail.Subject
Range("B1").Offset(i, 0) = OutlookMail.ReceivedTime
Range("C1").Offset(i, 0) = OutlookMail.SenderName
'Range("D1").Offset(i, 0) = OutlookMail.Body
               
i = i + 1

'If the email date set is crossed, then to to line number 3
Else: GoTo 3

End If
End If

Next OutlookMail
 
Set Folder = Nothing
Set OutlookNamespace = Nothing
Set OutlookApp = Nothing
 
'Do not wrap text of the imported emails
3 Sheet1.Cells.WrapText = False
 

Application.ScreenUpdating = True

'Pop up saying the import is complete
MsgBox "Email importing is done!", vbOKOnly + vbInformation

End Sub

After suggestions, I modified and tested with the below code. Cell L1 has date 12/08/2021 and cell L2 has date 16/08/2021. Now the code picks up the date range ignoring the emails that are later than 16/08/2021, however, it does not fetch the emails for the date 16/08/2021. It fetches the emails only until 15/08/2021. Inbox is sorted according to "Latest first" and there are emails for date 12/08/2021 and for 16/08/2021.

Sub Download_Emails()

Application.ScreenUpdating = False

Dim OutlookApp As Outlook.Application
Dim OutlookNamespace As Namespace
Dim Folder As MAPIFolder
Dim OutlookMail As Variant
Dim objOwner As Outlook.Recipient
Dim i As Integer
Dim olItems As Object
Dim olItem As Object
Dim LastRow As Long

LastRow = Cells(Rows.Count, "A").End(xlUp).Row

Set OutlookApp = New Outlook.Application
Set OutlookNamespace = OutlookApp.GetNamespace("MAPI")
Set objOwner = OutlookNamespace.CreateRecipient("xxxxxx.com")   'Set the Outlook mailbox name
objOwner.Resolve

'Allows the user to select the desired folder from which the emails are to be imported
If objOwner.Resolved Then
Set Folder = GetObject("", "Outlook.Application").GetNamespace("MAPI").PickFolder
End If

i = LastRow
LastRow = LastRow + 1


For Each OutlookMail In Folder.Items
If TypeName(OutlookMail) = "MailItem" Then

'Sets the date from which the user wants to import the emails from
If CDate(OutlookMail.ReceivedTime) > Range("L2").Value Then
    'Do nothing

ElseIf CDate(OutlookMail.ReceivedTime) >= Range("L1").Value Then ‘L1 has date 12/08/2021 and L2 has date 16/08/2021

'Imports email subject, received date and time, sender's name, and the email body into the excel file
Range("A1").Offset(i, 0) = OutlookMail.Subject
Range("B1").Offset(i, 0) = OutlookMail.ReceivedTime
Range("C1").Offset(i, 0) = OutlookMail.SenderName
'Range("D1").Offset(i, 0) = OutlookMail.Body
               
i = i + 1

'If the email date range is crossed, then exit For loop
Else: Exit For

End If
End If


Next OutlookMail
 
Set Folder = Nothing
Set OutlookNamespace = Nothing
Set OutlookApp = Nothing
 
'Do not wrap text of the imported emails
Sheet1.Cells.WrapText = False
 
Application.ScreenUpdating = True

'Pop up saying the import is complete
MsgBox "Email importing is done!", vbOKOnly + vbInformation

End Sub

Since I find fetching emails from Oldest to Newest suits me best, I tried to alter the codes. However, it exits the loop without doing anything. My mailbox is sorted from Oldest to Newest. I have emails from 2019 till date. I want to fetch emails that I have for the below given range. Cell L1 has the From date (28/08/2020). Cell L2 has the To date (30/08/2020).

Here is the code that I used. Since the macro exits the loop at the first instance, I think I am missing something in the logic.

Also, rather than instructing the user to have their mailbox sorted from oldest to newest, can we force the VBA to do that? I tried OutlookItems.Sort [ReceivedTime], true but got the error "Object Required". Now I have made it a comment in the code.

Sub Download_Emails()


Application.ScreenUpdating = False

Dim OutlookApp As Outlook.Application
Dim OutlookNamespace As Namespace
Dim Folder As MAPIFolder
Dim OutlookMail As Variant
Dim objOwner As Outlook.Recipient
Dim i As Integer
Dim olItems As Object
Dim olItem As Object
Dim LastRow As Long
Dim ToDt As Date

LastRow = Cells(Rows.Count, "A").End(xlUp).Row

ToDt = Range("L2").Value + 1

Set OutlookApp = New Outlook.Application
Set OutlookNamespace = OutlookApp.GetNamespace("MAPI")
Set objOwner = OutlookNamespace.CreateRecipient("xxxxxxxxxx.com")   'Set the Outlook mailbox name
objOwner.Resolve

'OutlookItems.Sort [ReceivedTime], true (results in error Object required)

'Allows the user to select the desired folder from which the emails are to be imported
If objOwner.Resolved Then
Set Folder = GetObject("", "Outlook.Application").GetNamespace("MAPI").PickFolder
End If

i = LastRow
LastRow = LastRow + 1


For Each OutlookMail In Folder.Items
If TypeName(OutlookMail) = "MailItem" Then

'Sets the date from which the user wants to import the emails from
If CDate(OutlookMail.ReceivedTime) < Range("L1").Value Then   'From Date
    'Do nothing
    
ElseIf CDate(OutlookMail.ReceivedTime) < ToDt Then   'To Date

'Imports email subject, received date and time, sender's name, and the email body into the excel file
Range("A1").Offset(i, 0) = OutlookMail.Subject
Range("B1").Offset(i, 0) = OutlookMail.ReceivedTime
Range("C1").Offset(i, 0) = OutlookMail.SenderName
'Range("D1").Offset(i, 0) = OutlookMail.Body
               
i = i + 1

'If the email date range is crossed, then exit For loop
Else: Exit For
End If
End If

Next OutlookMail
 
Set Folder = Nothing
Set OutlookNamespace = Nothing
Set OutlookApp = Nothing
 
'Do not wrap text of the imported emails
Sheet1.Cells.WrapText = False
 
Application.ScreenUpdating = True

'Pop up saying the import is complete
MsgBox "Email importing is done!", vbOKOnly + vbInformation

End Sub

Your code exits the loop as soon as it finds one mail which doesn't meet your date criteria... — Tim Williams
– Tim Williams, Commented Aug 20, 2021 at 17:17
@TimWilliams Thank you very much for the suggestion!! I tried removing that Else: GoTo 3, but then the macro runs forever because I guess it checks the entire mailbox that has 8000 emails. Is there chance to get the macro pick up emails for a given range? — Seema
– Seema, Commented Aug 20, 2021 at 17:51
Looking it up: A line label can be any combination of characters that starts with a letter and ends with a colon (:). Line labels are not case sensitive and must begin in the first column. Note starts with a letter and ends with a colon. Also, you should move the label up a few lines, to right after Next OutlookMail in order to close those Folder ... — Tom Brunberg
– Tom Brunberg, Commented Aug 20, 2021 at 18:20
Assuming the mails are ordered "latest first", L2 means last date to get, L1 means first date to get and RD means received date, then the logic would be: if RD > L2 then do_nothing else if RD >= L1 then get_mail_data else stop_looping. — Tom Brunberg
– Tom Brunberg, Commented Aug 20, 2021 at 21:18
Your first test (IF received time > L2 then do nothing) is correct. The next test is wrong, you should only test `IF received time > L1 THEN copy the email ELSE exit the search. There are 3 cases in all: 1) the email is newer than L2 - not interesting. 2) the email is newer than L1 - it is interesting (you don't need to test against L2 again, you already know it is older than L2) 3) the email, as well as subsequent ones, is older - not interesting, exit the search. — Tom Brunberg
– Tom Brunberg, Commented Aug 22, 2021 at 13:57

Tom Brunberg · Accepted Answer · 2021-08-22 14:06:18Z

1

Here's the selection code logic

For Each OutlookMail In Folder.Items
    If TypeName(OutlookMail) = "MailItem" Then

        If CDate(OutlookMail.ReceivedTime) > Range("L2").Value Then
            'do nothing, newer than the selected range

        ElseIf CDate(OutlookMail.ReceivedTime) >= Range("L1").Value Then
                'meaning that L2 => date >= L1
                'import email

            Else

                'date is < L1 not interested in these
                Exit For
            End If               
        End If
    End If
Next OutlookMail

answered Aug 22, 2021 at 14:06

Tom Brunberg

21.2k8 gold badges43 silver badges58 bronze badges

Sign up to request clarification or add additional context in comments.

3 Comments

Seema Over a year ago

Thanks so much for trying to help me! I tried, but it still fetches emails that are 1 day prior to the date mentioned in Cell L2.

Tom Brunberg Over a year ago

Probably the issue is the time component in the received time of a mail. If your L2 entry is e.g. 16.08.2021 it means that day at 00:00:00. An email received at 16.08.2021 12:00:00 is therefore filtered out. I suggest you increase the L2 value by one day in the formula: ( (Range("L2").Value) + 1) ). Alternative 1) direct the user to enter next days date. Alternative 2) remove the time component from the email datetime.

Seema Over a year ago

Thanks so much for the suggestion! I changed that and, it works fine. Once again, thanks a lot for helping me out on this!

dbmitch · Accepted Answer · 2021-08-22 17:36:24Z

0

If you're going to exit your processing loop based on the date, you better sort our items in the same order you expect.

Change

Dim OutlookMail As Variant

To

Dim OutlookMail As Outlook.MailItem
Dim OutlookItems As Outlook.Items

Change

For Each OutlookMail In Folder.Items

To

 Set OutlookItems = Folder.Items
 NumItems = OutlookItems.Count
 If NumItems = 0 Then Exit Sub

 OutlookItems.Sort [ReceivedTime], true ' sort in ascending order

 For Each OutlookMail In OutlookItems

Once in correct order you can record emails using Received Time filter

If CDate(OutlookMail.ReceivedTime) >= Range("L1").Value Then 'low filter

   IF CDate(OutlookMail.ReceivedTime) <= Range("L2").Value Then ' high filter
      ' Record your email data here
      '  ...
   Else ' All done - outside our processing range
      Exit For

   End If
End IF

answered Aug 22, 2021 at 17:36

dbmitch

5,3964 gold badges27 silver badges39 bronze badges

1 Comment

Seema Over a year ago

Thanks so much for taking time to modify the codes for me! I changed the codes as per your suggestion. Unfortunately, the macro doesn't fetch any emails. I guess it exits the loop when the very first email doesn't meet the search criteria.

Seema · Accepted Answer · 2021-08-25 14:13:22Z

With all the help that I got from experts on this platform, I modified the codes and got what I wanted. Posting it in case it helps someone looking for something like this in the future.

Sincere thanks to everyone who took time to help me.

Sub Download_Emails()


Application.ScreenUpdating = False

Dim OutlookApp As Outlook.Application
Dim OutlookNamespace As Namespace
Dim Folder As MAPIFolder
Dim OutlookMail As Variant
Dim objOwner As Outlook.Recipient
Dim i As Integer
Dim olItems As Object
Dim olItem As Object
Dim LastRow As Long
Dim ToDt As Date

LastRow = Cells(Rows.Count, "A").End(xlUp).Row

ToDt = Range("L2").Value + 1

Set OutlookApp = New Outlook.Application
Set OutlookNamespace = OutlookApp.GetNamespace("MAPI")
Set objOwner = OutlookNamespace.CreateRecipient("xxxxxxxxxx.com")   'Set the Outlook mailbox name
objOwner.Resolve

'Allows the user to select the desired folder from which the emails are to be imported
If objOwner.Resolved Then
Set Folder = GetObject("", "Outlook.Application").GetNamespace("MAPI").PickFolder
End If

i = LastRow
LastRow = LastRow + 1


For Each OutlookMail In Folder.Items
If TypeName(OutlookMail) = "MailItem" Then

'Sets the date from which the user wants to import the emails from
If CDate(OutlookMail.ReceivedTime) > ToDt Then
    'Do nothing
    
ElseIf CDate(OutlookMail.ReceivedTime) >= Range("L1").Value Then

'Imports email subject, received date and time, sender's name, and the email body into the excel file
Range("A1").Offset(i, 0) = OutlookMail.Subject
Range("B1").Offset(i, 0) = OutlookMail.ReceivedTime
Range("C1").Offset(i, 0) = OutlookMail.SenderName
'Range("D1").Offset(i, 0) = OutlookMail.Body
               
i = i + 1

'If the email date range is crossed, then exit For loop
Else: Exit For
End If
End If

Next OutlookMail


 
Set Folder = Nothing
Set OutlookNamespace = Nothing
Set OutlookApp = Nothing
 
'Do not wrap text of the imported emails
Sheet1.Cells.WrapText = False

 
Application.ScreenUpdating = True

'Pop up saying the import is complete
MsgBox "Email importing is done!", vbOKOnly + vbInformation

End Sub

Keith Swerling · Accepted Answer · 2021-08-25 19:03:57Z

Another method is to Restrict the email items, in this example, to a certain date. I just used this method recently and it works great. It is also easy to reverse the sort, although I liked the "OutlookItems.Sort [ReceivedTime], true ' sort in ascending order" method too.

Items.Restrict method (Outlook)

Sub GetFromOutlook()
    Dim i As Integer
    Dim EmailSender As String

Dim myOlApp As Outlook.Application
Dim myNamespace As Namespace
Dim myFolder As MAPIFolder
Dim OutlookMail As Variant

Set myOlApp = New Outlook.Application
Set myNamespace = myOlApp.GetNamespace("MAPI")

Set myFolder = myNamespace.GetDefaultFolder(olFolderInbox) '.Folders("Inbox") '.Folders("Subfolder")
    Set myItems = myFolder.Items

i = 1

     
Dim DateStart As Date
DateStart = #1/1/2021#
DateStart = Replace(DateStart, "1/1/2021", LastNewEmailDate)
Dim DateToCheck As String
    DateToCheck = "[LastModificationTime] >= """ & DateStart & """"
    
    Set myRestrictItems = myItems.Restrict(DateToCheck)      'Restrict("[Categories] = 'Business'")

Debug.Print "restrict count: " & myRestrictItems.Count

'Oldest first:
    For i = 1 To myRestrictItems.Count Step +1
'Newest first
   ' For i = myRestrictItems.Count To 1 Step -1

        If myRestrictItems(i).SenderEmailType = "SMTP" Then
            EmailSender = myRestrictItems(i).SenderEmailAddress
        End If

Debug.Print myRestrictItems(i).ReceivedTime

Next i

End Sub

Another Question on Outlook Restrictions that I had missed until now: Using Restrict method for emails within a specified date

Collectives™ on Stack Overflow

Import Outlook emails to Excel for specified Date Range

4 Answers 4

3 Comments

1 Comment

Comments

1 Comment

Your Answer

Linked

Hot Network Questions

Collectives™ on Stack Overflow

4 Answers 4

3 Comments

1 Comment

Comments

1 Comment

Your Answer

Sign up or log in

Post as a guest

Linked

Related