Vba to move emails from Inbox to personal folder

Pranesh

Board Regular
Joined
Jun 29, 2014
Messages
216
Hi,

I receive 20 to 25 emails a day from a common mail box daily to my Outlook 2016. I will then move those emails to a personal folder named "Daily email1" & "Daily email 2" based on email subject.

I want this to be automated. Whenever I get those emails I want a button to run a code which should move those emails to respective folder based on email subject. Once that is done I need Macro to prepare a report to say how many emails has been received from that email box and need a list of email subject with the mail received time in body of the email which should be sent to a user.

I searched online for VBA codes but no luck. Can someone help me.
 

Domenic

MrExcel MVP
Joined
Mar 10, 2004
Messages
19,012
The following macro should be placed in a regular module (Visual Basic Editor >> Insert >> Module). You'll need to change the code where specified. Also, as it stands, the code will only display the email, it won't send it. Once you've tested it and everything is fine, you can replace .display with .send, and then uncomment those few lines where indicated within the code.

Code:
Option Explicit

Sub MoveAndEmailReport()


    Dim olApp As Object
    Dim olNS As Object
    Dim olInBox As Object
    Dim olFolderDaily1 As Object
    Dim olFolderDaily2 As Object
    Dim olItem As Object
    Dim olMail As Object
    Dim strSearchForSubject1 As String
    Dim strSearchForSubject2 As String
    Dim strHtmlContents As String
    Dim strHtmlBody As String
    Dim blnStarted As Boolean
    Dim blnMoved As Boolean
    Dim emailCount As Long
    Dim itemIndex As Long
    
    On Error Resume Next
    'Get Outlook, if its already running
    Set olApp = GetObject(, "Outlook.Application")
    If olApp Is Nothing Then
        'Outlook wasn't already running, so start it
        Set olApp = CreateObject("Outlook.Application")
        If olApp Is Nothing Then
            MsgBox "Unable to open Outlook!", vbExclamation
            Exit Sub
        End If
        blnStarted = True
    End If
    On Error GoTo errHandler
    
    'Set namespace
    Set olNS = olApp.GetNamespace("MAPI")
    
    'Set inbox
    Set olInBox = olNS.GetDefaultFolder(6) 'olFolderInbox
    
    'Set first personal folder
    Set olFolderDaily1 = olNS.Folders("Daily email1")
    
    'Set second personal folder
    Set olFolderDaily2 = olNS.Folders("Daily email2")
    
    strSearchForSubject1 = "MySubject1" 'change first subject to search for
    strSearchForSubject2 = "MySubject2" 'change second subject to search for
    
    'Loop through each item in inbox, move items that meet the criteria to their
    'respective folder, collect relevant data in html table format, and keep track of
    'number of emails that met criteria and were moved
    strHtmlContents = ""
    emailCount = 0
    For itemIndex = olInBox.items.Count To 1 Step -1
        Set olItem = olInBox.items(itemIndex)
        If TypeName(olItem) = "MailItem" Then
            If InStr(1, olItem.Subject, strSearchForSubject1, vbTextCompare) > 0 Then
                olItem.Move olFolderDaily1
                blnMoved = True
            ElseIf InStr(1, olItem.Subject, strSearchForSubject2, vbTextCompare) Then
                olItem.Move olFolderDaily2
                blnMoved = True
            End If
            If blnMoved Then
                strHtmlContents = strHtmlContents & vbCrLf & "<tr>"
                strHtmlContents = strHtmlContents & vbCrLf & "<td>" & olItem.Subject & "</td>"
                strHtmlContents = strHtmlContents & vbCrLf & "<td>" & olItem.receivedtime & "</td>"
                strHtmlContents = strHtmlContents & vbCrLf & "</tr>"
                emailCount = emailCount + 1
                blnMoved = False
            End If
        End If
    Next itemIndex
    
    'If one or more emails met the criteria and were moved, add the necessary html code
    'to complete the formatting for the html table, and then create a new email with the data
    'collected and send it to the specified user
    If emailCount > 0 Then
        strHtmlBody = "<table width=100% border=1 cellpadding=3>"
        strHtmlBody = strHtmlBody & "<tr>"
        strHtmlBody = strHtmlBody & vbCrLf & "<th width=70% align=left>Subject</th>"
        strHtmlBody = strHtmlBody & vbCrLf & "<th align=left>Received Time</th>"
        strHtmlBody = strHtmlBody & vbCrLf & "</tr>"
        strHtmlBody = strHtmlBody & vbCrLf & strHtmlContents
        strHtmlBody = strHtmlBody & vbCrLf & "</table>"
        Set olMail = olApp.CreateItem(0)
        With olMail
            .To = "johnsmith@example.com" 'change the email address accordingly
            .Subject = "List of emails received" 'change the subject accordingly
            .htmlbody = "<p>Number of emails received: " & emailCount & "</p>"
            .htmlbody = .htmlbody & strHtmlBody
            .display 'to display email instead of sending it
            '.send 'to send email instead of displaying it
        End With
        MsgBox emailCount & " email(s) received and moved, and report sent.", vbInformation
    Else
        MsgBox "No emails received.", vbInformation
    End If
    
exitHandler:
    'If Outlook was started, close it
    'Uncomment next 3 lines when emails are actual being sent
    'If blnStarted Then
        'olApp.Quit
    'End If
    
    Set olApp = Nothing
    Set olNS = Nothing
    Set olInBox = Nothing
    Set olFolderDaily1 = Nothing
    Set olFolderDaily2 = Nothing
    Set olItem = Nothing
    Set olMail = Nothing
    
    Exit Sub
    
errHandler:
    MsgBox "Error " & Err.Number & ":" & vbCrLf & vbCrLf & Err.Description, vbCritical, "Error"
    Resume exitHandler
    
End Sub
 

Pranesh

Board Regular
Joined
Jun 29, 2014
Messages
216
The following macro should be placed in a regular module (Visual Basic Editor >> Insert >> Module). You'll need to change the code where specified. Also, as it stands, the code will only display the email, it won't send it. Once you've tested it and everything is fine, you can replace .display with .send, and then uncomment those few lines where indicated within the code.

Code:
Option Explicit

Sub MoveAndEmailReport()


    Dim olApp As Object
    Dim olNS As Object
    Dim olInBox As Object
    Dim olFolderDaily1 As Object
    Dim olFolderDaily2 As Object
    Dim olItem As Object
    Dim olMail As Object
    Dim strSearchForSubject1 As String
    Dim strSearchForSubject2 As String
    Dim strHtmlContents As String
    Dim strHtmlBody As String
    Dim blnStarted As Boolean
    Dim blnMoved As Boolean
    Dim emailCount As Long
    Dim itemIndex As Long
    
    On Error Resume Next
    'Get Outlook, if its already running
    Set olApp = GetObject(, "Outlook.Application")
    If olApp Is Nothing Then
        'Outlook wasn't already running, so start it
        Set olApp = CreateObject("Outlook.Application")
        If olApp Is Nothing Then
            MsgBox "Unable to open Outlook!", vbExclamation
            Exit Sub
        End If
        blnStarted = True
    End If
    On Error GoTo errHandler
    
    'Set namespace
    Set olNS = olApp.GetNamespace("MAPI")
    
    'Set inbox
    Set olInBox = olNS.GetDefaultFolder(6) 'olFolderInbox
    
    'Set first personal folder
    Set olFolderDaily1 = olNS.Folders("Daily email1")
    
    'Set second personal folder
    Set olFolderDaily2 = olNS.Folders("Daily email2")
    
    strSearchForSubject1 = "MySubject1" 'change first subject to search for
    strSearchForSubject2 = "MySubject2" 'change second subject to search for
    
    'Loop through each item in inbox, move items that meet the criteria to their
    'respective folder, collect relevant data in html table format, and keep track of
    'number of emails that met criteria and were moved
    strHtmlContents = ""
    emailCount = 0
    For itemIndex = olInBox.items.Count To 1 Step -1
        Set olItem = olInBox.items(itemIndex)
        If TypeName(olItem) = "MailItem" Then
            If InStr(1, olItem.Subject, strSearchForSubject1, vbTextCompare) > 0 Then
                olItem.Move olFolderDaily1
                blnMoved = True
            ElseIf InStr(1, olItem.Subject, strSearchForSubject2, vbTextCompare) Then
                olItem.Move olFolderDaily2
                blnMoved = True
            End If
            If blnMoved Then
                strHtmlContents = strHtmlContents & vbCrLf & "<tr>"
                strHtmlContents = strHtmlContents & vbCrLf & "<td>" & olItem.Subject & "</td>"
                strHtmlContents = strHtmlContents & vbCrLf & "<td>" & olItem.receivedtime & "</td>"
                strHtmlContents = strHtmlContents & vbCrLf & "</tr>"
                emailCount = emailCount + 1
                blnMoved = False
            End If
        End If
    Next itemIndex
    
    'If one or more emails met the criteria and were moved, add the necessary html code
    'to complete the formatting for the html table, and then create a new email with the data
    'collected and send it to the specified user
    If emailCount > 0 Then
        strHtmlBody = "<table width=100% border=1 cellpadding=3>"
        strHtmlBody = strHtmlBody & "<tr>"
        strHtmlBody = strHtmlBody & vbCrLf & "<th width=70% align=left>Subject</th>"
        strHtmlBody = strHtmlBody & vbCrLf & "<th align=left>Received Time</th>"
        strHtmlBody = strHtmlBody & vbCrLf & "</tr>"
        strHtmlBody = strHtmlBody & vbCrLf & strHtmlContents
        strHtmlBody = strHtmlBody & vbCrLf & "</table>"
        Set olMail = olApp.CreateItem(0)
        With olMail
            .To = "johnsmith@example.com" 'change the email address accordingly
            .Subject = "List of emails received" 'change the subject accordingly
            .htmlbody = "<p>Number of emails received: " & emailCount & "</p>"
            .htmlbody = .htmlbody & strHtmlBody
            .display 'to display email instead of sending it
            '.send 'to send email instead of displaying it
        End With
        MsgBox emailCount & " email(s) received and moved, and report sent.", vbInformation
    Else
        MsgBox "No emails received.", vbInformation
    End If
    
exitHandler:
    'If Outlook was started, close it
    'Uncomment next 3 lines when emails are actual being sent
    'If blnStarted Then
        'olApp.Quit
    'End If
    
    Set olApp = Nothing
    Set olNS = Nothing
    Set olInBox = Nothing
    Set olFolderDaily1 = Nothing
    Set olFolderDaily2 = Nothing
    Set olItem = Nothing
    Set olMail = Nothing
    
    Exit Sub
    
errHandler:
    MsgBox "Error " & Err.Number & ":" & vbCrLf & vbCrLf & Err.Description, vbCritical, "Error"
    Resume exitHandler
    
End Sub
Hi Domenic,

Thank you so much for your help. I pasted the code in a Module in excel and try to run it. Im getting "An object could not be found" error. I guess it is not finding the folder. Under personal folder I have a group name called "DailyMail" and under that I have these 2 folders Daily email1 & Daily email2.

Based on subject I will have more emails with same name and at the end there will be names added which will differentiate each email. Instead of that as said earlier received all those emails from a common mail box. So can the code be changed as to moved all emails received from that common mail box to Daily email1?
 

Domenic

MrExcel MVP
Joined
Mar 10, 2004
Messages
19,012
Hi Domenic,
Hi Pranesh!

Thank you so much for your help. I pasted the code in a Module in excel and try to run it. Im getting "An object could not be found" error. I guess it is not finding the folder. Under personal folder I have a group name called "DailyMail" and under that I have these 2 folders Daily email1 & Daily email2.
In that case, try the following instead..

Code:
    'Set first daily folder
    Set olFolderDaily1 = olNS.Folders("DailyMail").Folders("Daily email1")
    
    'Set second daily folder
    Set olFolderDaily2 = olNS.Folders("DailyMail").Folders("Daily email2")
Based on subject I will have more emails with same name and at the end there will be names added which will differentiate each email. Instead of that as said earlier received all those emails from a common mail box. So can the code be changed as to moved all emails received from that common mail box to Daily email1?
I don't understand. Can you please explain? Also, can you provide some examples?
 
Last edited:

Pranesh

Board Regular
Joined
Jun 29, 2014
Messages
216
Hi Pranesh!



In that case, try the following instead..

Code:
    'Set first daily folder
    Set olFolderDaily1 = olNS.Folders("DailyMail").Folders("Daily email1")
    
    'Set second daily folder
    Set olFolderDaily2 = olNS.Folders("DailyMail").Folders("Daily email2")


I don't understand. Can you please explain? Also, can you provide some examples?
Hi,

Thanks for your help.

My email subject will be like Daily mailer - NA, Daily Mailer - UK, Daily Mailer - APAC likewise I will have emails, so instead of moving the mails based on email subject, I would like to move the mails based on received from email address.

So all the emails received from that email should be moved to only 1 folder named "Daily Mailers"
 

Domenic

MrExcel MVP
Joined
Mar 10, 2004
Messages
19,012
The following macro has been amended so that emails received from a specified email address will be moved, etc....

Code:
Option Explicit

Sub MoveAndEmailReport()


    Dim olApp As Object
    Dim olNS As Object
    Dim olInBox As Object
    Dim olMoveToFolder As Object
    Dim olItem As Object
    Dim olMail As Object
    Dim strHtmlContents As String
    Dim strHtmlBody As String
    Dim blnStarted As Boolean
    Dim emailCount As Long
    Dim itemIndex As Long
    
    On Error Resume Next
    'Get Outlook, if its already running
    Set olApp = GetObject(, "Outlook.Application")
    If olApp Is Nothing Then
        'Outlook wasn't already running, so start it
        Set olApp = CreateObject("Outlook.Application")
        If olApp Is Nothing Then
            MsgBox "Unable to open Outlook!", vbExclamation
            Exit Sub
        End If
        blnStarted = True
    End If
    On Error GoTo errHandler
    
    'Set namespace
    Set olNS = olApp.GetNamespace("MAPI")
    
    'Set inbox
    Set olInBox = olNS.GetDefaultFolder(6) 'olFolderInbox
    
    'Set folder to move emails to
    Set olMoveToFolder = olNS.Folders("DailyMail").Folders("Daily Mailers")
    
    'Loop through each item in inbox, move items that meet the criteria to their
    'respective folder, collect relevant data in html table format, and keep track of
    'number of emails that met criteria and were moved
    strHtmlContents = ""
    emailCount = 0
    For itemIndex = olInBox.items.Count To 1 Step -1
        Set olItem = olInBox.items(itemIndex)
        If TypeName(olItem) = "MailItem" Then
            If olItem.SenderEmailAddress = "janedoe@example.com" Then 'change the email address accordingly
                strHtmlContents = strHtmlContents & vbCrLf & "<tr>"
                strHtmlContents = strHtmlContents & vbCrLf & "<td>" & olItem.Subject & "</td>"
                strHtmlContents = strHtmlContents & vbCrLf & "<td>" & olItem.receivedtime & "</td>"
                strHtmlContents = strHtmlContents & vbCrLf & "</tr>"
                olItem.Move olMoveToFolder
                emailCount = emailCount + 1
            End If
        End If
    Next itemIndex
    
    'If one or more emails met the criteria and were moved, add the necessary html code
    'to complete the formatting for the html table, and then create a new email with the data
    'collected and send it to the specified user
    If emailCount > 0 Then
        strHtmlBody = "<table width=100% border=1 cellpadding=3>"
        strHtmlBody = strHtmlBody & "<tr>"
        strHtmlBody = strHtmlBody & vbCrLf & "<th width=70% align=left>Subject</th>"
        strHtmlBody = strHtmlBody & vbCrLf & "<th align=left>Received Time</th>"
        strHtmlBody = strHtmlBody & vbCrLf & "</tr>"
        strHtmlBody = strHtmlBody & vbCrLf & strHtmlContents
        strHtmlBody = strHtmlBody & vbCrLf & "</table>"
        Set olMail = olApp.CreateItem(0)
        With olMail
            .To = "johnsmith@example.com" 'change the email address accordingly
            .Subject = "List of emails received" 'change the subject accordingly
            .htmlbody = "<p>Number of emails received: " & emailCount & "</p>"
            .htmlbody = .htmlbody & strHtmlBody
            .display 'to display email instead of sending it
            '.send 'to send email instead of displaying it
        End With
        MsgBox emailCount & " email(s) received and moved, and report sent.", vbInformation
    Else
        MsgBox "No emails received.", vbInformation
    End If
    
exitHandler:
    'If Outlook was started, close it
    'Uncomment next 3 lines when emails are actual being sent
    'If blnStarted Then
        'olApp.Quit
    'End If
    
    Set olApp = Nothing
    Set olNS = Nothing
    Set olInBox = Nothing
    Set olMoveToFolder = Nothing
    Set olItem = Nothing
    Set olMail = Nothing
    
    Exit Sub
    
errHandler:
    MsgBox "Error " & Err.Number & ":" & vbCrLf & vbCrLf & Err.Description, vbCritical, "Error"
    Resume exitHandler
    
End Sub
 

Pranesh

Board Regular
Joined
Jun 29, 2014
Messages
216
The following macro has been amended so that emails received from a specified email address will be moved, etc....

Code:
Option Explicit

Sub MoveAndEmailReport()


    Dim olApp As Object
    Dim olNS As Object
    Dim olInBox As Object
    Dim olMoveToFolder As Object
    Dim olItem As Object
    Dim olMail As Object
    Dim strHtmlContents As String
    Dim strHtmlBody As String
    Dim blnStarted As Boolean
    Dim emailCount As Long
    Dim itemIndex As Long
    
    On Error Resume Next
    'Get Outlook, if its already running
    Set olApp = GetObject(, "Outlook.Application")
    If olApp Is Nothing Then
        'Outlook wasn't already running, so start it
        Set olApp = CreateObject("Outlook.Application")
        If olApp Is Nothing Then
            MsgBox "Unable to open Outlook!", vbExclamation
            Exit Sub
        End If
        blnStarted = True
    End If
    On Error GoTo errHandler
    
    'Set namespace
    Set olNS = olApp.GetNamespace("MAPI")
    
    'Set inbox
    Set olInBox = olNS.GetDefaultFolder(6) 'olFolderInbox
    
    'Set folder to move emails to
    Set olMoveToFolder = olNS.Folders("DailyMail").Folders("Daily Mailers")
    
    'Loop through each item in inbox, move items that meet the criteria to their
    'respective folder, collect relevant data in html table format, and keep track of
    'number of emails that met criteria and were moved
    strHtmlContents = ""
    emailCount = 0
    For itemIndex = olInBox.items.Count To 1 Step -1
        Set olItem = olInBox.items(itemIndex)
        If TypeName(olItem) = "MailItem" Then
            If olItem.SenderEmailAddress = "janedoe@example.com" Then 'change the email address accordingly
                strHtmlContents = strHtmlContents & vbCrLf & "<tr>"
                strHtmlContents = strHtmlContents & vbCrLf & "<td>" & olItem.Subject & "</td>"
                strHtmlContents = strHtmlContents & vbCrLf & "<td>" & olItem.receivedtime & "</td>"
                strHtmlContents = strHtmlContents & vbCrLf & "</tr>"
                olItem.Move olMoveToFolder
                emailCount = emailCount + 1
            End If
        End If
    Next itemIndex
    
    'If one or more emails met the criteria and were moved, add the necessary html code
    'to complete the formatting for the html table, and then create a new email with the data
    'collected and send it to the specified user
    If emailCount > 0 Then
        strHtmlBody = "<table width=100% border=1 cellpadding=3>"
        strHtmlBody = strHtmlBody & "<tr>"
        strHtmlBody = strHtmlBody & vbCrLf & "<th width=70% align=left>Subject</th>"
        strHtmlBody = strHtmlBody & vbCrLf & "<th align=left>Received Time</th>"
        strHtmlBody = strHtmlBody & vbCrLf & "</tr>"
        strHtmlBody = strHtmlBody & vbCrLf & strHtmlContents
        strHtmlBody = strHtmlBody & vbCrLf & "</table>"
        Set olMail = olApp.CreateItem(0)
        With olMail
            .To = "johnsmith@example.com" 'change the email address accordingly
            .Subject = "List of emails received" 'change the subject accordingly
            .htmlbody = "<p>Number of emails received: " & emailCount & "</p>"
            .htmlbody = .htmlbody & strHtmlBody
            .display 'to display email instead of sending it
            '.send 'to send email instead of displaying it
        End With
        MsgBox emailCount & " email(s) received and moved, and report sent.", vbInformation
    Else
        MsgBox "No emails received.", vbInformation
    End If
    
exitHandler:
    'If Outlook was started, close it
    'Uncomment next 3 lines when emails are actual being sent
    'If blnStarted Then
        'olApp.Quit
    'End If
    
    Set olApp = Nothing
    Set olNS = Nothing
    Set olInBox = Nothing
    Set olMoveToFolder = Nothing
    Set olItem = Nothing
    Set olMail = Nothing
    
    Exit Sub
    
errHandler:
    MsgBox "Error " & Err.Number & ":" & vbCrLf & vbCrLf & Err.Description, vbCritical, "Error"
    Resume exitHandler
    
End Sub
Hi Domenic,

Thanks for your time.

I Run the code this time it correctly identified the Folder which was created. I have updated the email address where you have said me to change it. But I received a Msg box stating No mails received, but im having 10 emails in my Inbox.
 

Domenic

MrExcel MVP
Joined
Mar 10, 2004
Messages
19,012
Since the comparison is case-sensitive, try replacing...

Code:
If olItem.SenderEmailAddress = "janedoe@example.com"
with

Code:
If UCase(olItem.SenderEmailAddress) = "JANEDOE@EXAMPLE.COM"
Does this help?
 

Pranesh

Board Regular
Joined
Jun 29, 2014
Messages
216
Since the comparison is case-sensitive, try replacing...

Code:
If olItem.SenderEmailAddress = "janedoe@example.com"
with

Code:
If UCase(olItem.SenderEmailAddress) = "JANEDOE@EXAMPLE.COM"
Does this help?
Hi Domenic,

I'm still getting the same error. That common email ID will be a combination of Upper and Lower case.
 

Domenic

MrExcel MVP
Joined
Mar 10, 2004
Messages
19,012
The reason I asked you to replace that line is so that the comparison would not be case-sensitive. So when you change the email address in the code to the actual email address, simply make sure that the email address is all capitals. This way it won't matter how the address appears in the email itself.
 

Forum statistics

Threads
1,082,135
Messages
5,363,344
Members
400,729
Latest member
Lisa McConachy

Some videos you may like

This Week's Hot Topics

  • populate from drop list with multiple tables
    Hi All, i have a drop list that displays data, what i want is when i select one of those from the list to populate text from different tables on...
  • Find list of words from sheet2 in sheet1 before a comma and extract text vba
    Hi Friends, Trying to find the solution on my task. But did not find suitable one to the need. Here is my query and sample file with details...
  • Dynamic Formula entry - VBA code sought
    Hello, really hope one of you experts can help with this - i've spent hours on this and getting no-where. .I have a set of data (more rows than...
  • Listbox Header
    Have a named range called "AccidentsHeader" Within my code I have: [CODE]Private Sub CommandButton1_Click() ListBox1.RowSource =...
  • Complex Heat Map using conditional formatting
    Good day excel world. I have a concern. Below link have a list of countries that carries each country unique data. [URL...
  • Conditional formatting
    Hi good morning, hope you can help me please, I have cells P4:P54 and if this cell is equal to 1 then i want row O to say "Fully Utilised" and to...
Top