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.
 

Some videos you may like

Excel Facts

Which came first: VisiCalc or Lotus 1-2-3?
Dan Bricklin and Bob Frankston debuted VisiCalc in 1979 as a Visible Calculator. Lotus 1-2-3 debuted in the early 1980's, from Mitch Kapor.

Domenic

MrExcel MVP
Joined
Mar 10, 2004
Messages
19,211
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,211
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,211
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,211
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,211
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.
 

Watch MrExcel Video

Forum statistics

Threads
1,102,778
Messages
5,488,808
Members
407,658
Latest member
Arias610

This Week's Hot Topics

  • Timer in VBA - Stop, Start, Pause and Reset
    [CODE=vba][/CODE] Option Explicit Dim CmdStop As Boolean Dim Paused As Boolean Dim Start Dim TimerValue As Date Dim pausedTime As Date Sub...
  • how to updates multiple rows in muliselect listbox
    Hello everyone. I need help with below code. code is only chaning 1st row in mulitiselect list box. i know issue with code...
  • Delete Row from Table
    I am trying to delete a row from a table using VBA using a named range to find what I need to delete. My Range is finding the right cell. In the...
  • Assigning to a variable
    I have a for each block where I want to assign the value in column 5 of the found row to the variable Serv. [CODE=vba] For Each ws In...
  • Way to verify information
    Hi All, I don't know what to call this formula, and therefore can't search. I have a spreadsheet with information I want to reference...
  • Active Cell Address – Inactive Sheet
    How to use VBA to get the cell address of the active cell in an inactive worksheet and then place that cell address in a location on the current...
Top