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.
 
In that case, the code in Post #6 in this thread should work. Can you confirm whether the "Inbox" is your default inbox? Or whether it's an inbox within a personal folder? It might help if you posted an image of the folder structure in Outlook.




That line checks whether the item is a mail item, meeting item, etc. It resolves to True if the item is a mail item. If you stop your code at that line and move your cursor over olItem, it should display the subject.


Hi Domenic,


As you said i took post#6 and run it but it was not working and found that the receipient address is the only issue. Senderemailaddress is not only taking the email id or name, but before that there are someother things included. So i copied that entirely and run the macro and it worked perfectly.


Thank you so much for your patience and help till now. I need few more help from you.


1, Instead of searching the entire inbox i need to pick only the specific date to search for emails. For example if i give 05/27/2019 in cell A1 it should look for emails received only on that date and move those mails and created table.

2, Usually i receive those mailers between 9-10AM and i might run this Macro by 11AM. By that time sometimes there would be some queries raised on any of the emails and there would be reply from the DL with subject starting as RE: or FW: so the macro moves the RE: & FW: emails as well and that should not happen. Basically it should move only mails with subject not starting as RE: or FW:

3, Need to include "S.No" as 1st column in table followed by email subject and received time.

4, In addition to it i need one more column to be included. There are few emails which will be received on 8:30AM daily at times due to some technical issue the email would have received by 9:30 or 10:00AM. I have the list of emails(Column A) and the time they usually receive(Column B) in the excel sheet where i run this macro. I need the macro to compare the received time which is updated in table(Macro output) with the usuall receive time i have in the excell and should give status as "On Time" if it has received 30min prior the original receive time or 30min after the original receive time, else it should update as "__Min Delay"(For example - if the mail received time is updated in excel as 8:30AM and if the mail is received between 8:00AM to 9:00AM it should be "On Time". If the email is received after 9:01AM then the status should be updated as "__Min Delay" based on the delay time.


Sorry to disturb you a lot. Thanks for helping me. Hope you would help me with this additional request as well.
 
Upvote 0

Excel Facts

Select a hidden cell
Somehide hide payroll data in column G? Press F5. Type G1. Enter. Look in formula bar while you arrow down through G.
I've only had a chance to address #1 and #2 , so I suggested you start a new thread for help with #3 and #4 . Here's the code, which has been amended to address #1 and #2 ...

HTML:
Sub MoveAndEmailReport()

    Dim olApp As Object
    Dim olNS As Object
    Dim olInBox As Object
    Dim olRestrictedItems As Object
    Dim strFilter1 As String
    Dim strFilter2 As String
    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
    
    'Filter items for date specified in cell A1 in Sheet1 (change the sheet reference accordingly)
    strFilter1 = "[ReceivedTime] >= '" & Format(Worksheets("Sheet1").Range("A1").Value, "ddddd h:nn AMPM") & "'"
    strFilter2 = "[ReceivedTime] < '" & Format(Worksheets("Sheet1").Range("A1").Value + 1, "ddddd h:nn AMPM") & "'"
    Set olRestrictedItems = olInBox.Items.Restrict(strFilter1 & " And " & strFilter2)
    
    '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 = olRestrictedItems.Count To 1 Step -1
        Set olItem = olRestrictedItems(itemIndex)
        If TypeName(olItem) = "MailItem" Then
            If olItem.SenderEmailAddress = "janedoe@example.com" Then 'change the email address accordingly
                If UCase(Left(olItem.Subject, 3)) <> "RE:" And UCase(Left(olItem.Subject, 3)) <> "FW:" Then
                    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
        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 olRestrictedItems = 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

Hope this helps!
 
Upvote 0
I've only had a chance to address [URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=1]#1 [/URL] and [URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=2]#2 [/URL] , so I suggested you start a new thread for help with #3 and #4 . Here's the code, which has been amended to address [URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=1]#1 [/URL] and [URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=2]#2 [/URL] ...

HTML:
Sub MoveAndEmailReport()

    Dim olApp As Object
    Dim olNS As Object
    Dim olInBox As Object
    Dim olRestrictedItems As Object
    Dim strFilter1 As String
    Dim strFilter2 As String
    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
    
    'Filter items for date specified in cell A1 in Sheet1 (change the sheet reference accordingly)
    strFilter1 = "[ReceivedTime] >= '" & Format(Worksheets("Sheet1").Range("A1").Value, "ddddd h:nn AMPM") & "'"
    strFilter2 = "[ReceivedTime] < '" & Format(Worksheets("Sheet1").Range("A1").Value + 1, "ddddd h:nn AMPM") & "'"
    Set olRestrictedItems = olInBox.Items.Restrict(strFilter1 & " And " & strFilter2)
    
    '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 = olRestrictedItems.Count To 1 Step -1
        Set olItem = olRestrictedItems(itemIndex)
        If TypeName(olItem) = "MailItem" Then
            If olItem.SenderEmailAddress = "janedoe@example.com" Then 'change the email address accordingly
                If UCase(Left(olItem.Subject, 3)) <> "RE:" And UCase(Left(olItem.Subject, 3)) <> "FW:" Then
                    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
        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 olRestrictedItems = 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

Hope this helps!

Hi Domenic,


Thank you so much for your help till now. The code works perfectly for the #1 & #2 . I will create a new thread for the remaining.


Meanwhile I'm trying to just copy the table which is defined as strHtmlbody to the excel sheet where i run this. But im unable to paste it. Below is the code which i use. Any suggestions to work it out.

Code:
tw.Activate
        Sheet1.Select
        Range("A3").Select
        Selection.Value = strHtmlBody
 
Upvote 0
I'm not sure what you mean by "unable to paste it". If you want to copy the table itself to Excel, without the html code, try...

Code:
olMail.GetInspector.WordEditor.Tables(1).Range.Copy
Sheet1.Paste Sheet1.Range("A3")
 
Upvote 0
I'm not sure what you mean by "unable to paste it". If you want to copy the table itself to Excel, without the html code, try...

Code:
olMail.GetInspector.WordEditor.Tables(1).Range.Copy
Sheet1.Paste Sheet1.Range("A3")

Hi Domenic,


This is what i expected. Your code works perfect. You made my work easier with help of your code. Thank you so much for all your time and help till now. I hope and wish your help will continue when again i post a new thread.
 
Upvote 0
You're very welcome!

Cheers!

Hi Domenic,


Sorry to disturb you again.


Everything is working fine in this Macro. I have one small correction to be made. Please help me if you can.


Now if i give the date as 6/26/2019 the macro pulls all the emails received on that datel. I need a correction here. If i give date as 6/26/2019 1:00 PM it should move the mails received on 6/26/2019 from 12:00 AM to till 1:00 PM. If i update date as 6/26/2019 2:00 PM then it should move the mails received on 6/26/2019 from 2:00 PM to 6/26/2019 11:59 PM.

Thanks in advance for your help.
 
Upvote 0
Let's say that A1 contains 6/26/2019 1:00 PM. To get the starting time of 6/26/2019 12:00 AM, you would use the Int function...

Code:
Int(Worksheets("Sheet1").Range("A1").Value)


And for the ending time of 6/26/2019 1:00 PM, you would simply use...

Code:
Worksheets("Sheet1").Range("A1").Value


Therefore your filters would be as follows...

Code:
    'Filter items for date specified in cell A1
    strFilter1 = "[ReceivedTime] >= '" & Format(Int(Worksheets("Sheet1").Range("A1").Value), "ddddd h:nn AMPM") & "'"
    strFilter2 = "[ReceivedTime] < '" & Format(Worksheets("Sheet1").Range("A1").Value, "ddddd h:nn AMPM") & "'"


Hope this helps!
 
Upvote 0
Let's say that A1 contains 6/26/2019 1:00 PM. To get the starting time of 6/26/2019 12:00 AM, you would use the Int function...

Code:
Int(Worksheets("Sheet1").Range("A1").Value)


And for the ending time of 6/26/2019 1:00 PM, you would simply use...

Code:
Worksheets("Sheet1").Range("A1").Value


Therefore your filters would be as follows...

Code:
    'Filter items for date specified in cell A1
    strFilter1 = "[ReceivedTime] >= '" & Format(Int(Worksheets("Sheet1").Range("A1").Value), "ddddd h:nn AMPM") & "'"
    strFilter2 = "[ReceivedTime] < '" & Format(Worksheets("Sheet1").Range("A1").Value, "ddddd h:nn AMPM") & "'"


Hope this helps!


Hi Domenic,


Thank you so much for your response and help.


I applied the code you provided it is moving emails received till 1:00 AM.


I think i didnt clearly explain what im looking for. Actually i will run this macro twice a day. Morning between 7 to 11 i will receive a set of emails and between 3:00PM to 7:00PM i will receive few set of emails so i run this twice a day.


If im on leave i will run it the next day by updating previous date in Range("A1") and the macro will move all the emails received through out the day and thats is why i need a split in moving this email.


My sugesstion is if i have date as 6/27/2019 in Range("A1") and "Morning" in Range("A2") then macro should move the emails received between 6/27/2019 12:00 AM to 02:00 PM. If if update Range("A2") as "Evening" then macro should move emails received on 6/27/2019 between 02:01 PM to 11:59 PM.

Thanks again for your help.
 
Upvote 0
In that case, try the following...

Code:
    'Filter items for date specified in cell A1
    If UCase(Worksheets("Sheet1").Range("A2")) = "MORNING" Then
        strFilter1 = "[ReceivedTime] >= '" & Format(Worksheets("Sheet1").Range("A1").Value, "ddddd h:nn AMPM") & "'"
        strFilter2 = "[ReceivedTime] < '" & Format(Worksheets("Sheet1").Range("A1").Value + TimeValue("2:00 PM"), "ddddd h:nn AMPM") & "'"
    ElseIf UCase(Worksheets("Sheet1").Range("A2")) = "EVENING" Then
        strFilter1 = "[ReceivedTime] >= '" & Format(Worksheets("Sheet1").Range("A1").Value + TimeValue("2:00 PM"), "ddddd h:nn AMPM") & "'"
        strFilter2 = "[ReceivedTime] < '" & Format(Worksheets("Sheet1").Range("A1").Value + 1, "ddddd h:nn AMPM") & "'"
    End If
 
Last edited:
Upvote 0

Forum statistics

Threads
1,213,524
Messages
6,114,117
Members
448,549
Latest member
brianhfield

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