Vba to move emails from Inbox to personal folder

Pranesh

Board Regular
Joined
Jun 29, 2014
Messages
219
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.
 

Excel Facts

Formula for Yesterday
Name Manager, New Name. Yesterday =TODAY()-1. OK. Then, use =YESTERDAY in any cell. Tomorrow could be =TODAY()+1.
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
 
Upvote 0
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?
 
Upvote 0
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:
Upvote 0
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"
 
Upvote 0
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
 
Upvote 0
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.
 
Upvote 0
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?
 
Upvote 0
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.
 
Upvote 0
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.
 
Upvote 0

Forum statistics

Threads
1,213,536
Messages
6,114,202
Members
448,554
Latest member
Gleisner2

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top