We had a question from a user who wanted a macro to move mail to a subfolder as it aged. While you could use AutoArchive to do this quickly and easily, no coding required, AutoArchive moves mail to a *.pst file, not a subfolder. If you don't care where the mail is moved to, just that its out of your Inbox, use AutoArchive, set to run every 1 day and configure the Inbox archive setting to the desired number of days.
To use, assign the macro to a command button and run as needed. You could also use this as an application start macro and have it run when Outlook starts.
If you aren't a big fan of moving mail, you can leave it in the Inbox and use custom views to hide older mail.
There are 4 macros on this page plus one code snippet. Two macros show you how to move messages to a folder within your current data file and to move messages to a folder in a new data file. The third macro on this page shows you how to use a Select Case statement to move different Outlook items types, using a different age for each item type. The code sample gives you the code needed to move only messages you've replied to or forwarded. "Macro to file Outlook email by sender's display name" has versions that file into folders by name, domain, or date.
VBA Macro to Move Aged Email Messages
This code sample checks the default Inbox for email older that 7 days and moves any it finds to a subfolder of the Inbox, called Old.
You'll need to set the age, in days, to your desired number. This sample uses 7 days. You'll also need to replace the data file name.
In this sample, the data file name is an email address because that is what Outlook 2010 uses for data file names. You'll need to change this as well as the folder path you are moving the email to.
Tested in Outlook 2010 and Outlook 2013 with an Exchange mailbox.
The Date field can either be SentOnor ReceivedTime when you are working with email or meeting request and responses.
Sub MoveAgedMail() Dim objOutlook As Outlook.Application Dim objNamespace As Outlook.NameSpace Dim objSourceFolder As Outlook.MAPIFolder Dim objDestFolder As Outlook.MAPIFolder Dim objVariant As Variant Dim lngMovedItems As Long Dim intCount As Integer Dim intDateDiff As Integer Dim strDestFolder As String Set objOutlook = Application Set objNamespace = objOutlook.GetNamespace("MAPI") Set objSourceFolder = objNamespace.GetDefaultFolder(olFolderInbox) ' use a subfolder under Inbox Set objDestFolder = objSourceFolder.Folders("Old") For intCount = objSourceFolder.Items.Count To 1 Step -1 Set objVariant = objSourceFolder.Items.Item(intCount) DoEvents If objVariant.Class = olMail Then intDateDiff = DateDiff("d", objVariant.SentOn, Now) ' I'm using 7 days, adjust as needed. If intDateDiff > 7 Then objVariant.Move objDestFolder 'count the # of items moved lngMovedItems = lngMovedItems + 1 End If End If Next ' Display the number of items that were moved. MsgBox "Moved " & lngMovedItems & " messages(s)." Set objDestFolder = Nothing End Sub
Move messages to a different data file
If you want to move the messages to a new data file, you need to change the destination folder path: Set objDestFolder = objNamespace.Folders("me@domain.com").Folders("Inbox").Folders("Old") to use the GetFolderPath function: Set objDestFolder = GetFolderPath("new-pst-file\folder-name").
That line is the only change needed to use a different data file (well, that line and the function).
Tip: A function can be used by any macro, so I keep the functions together in a separate module. When I add a macro that uses a function, I can easily see if I have that function already.
Sub MoveAgedMail2() 'Get the function fromhttp://slipstick.me/qf Dim objOutlook As Outlook.Application Dim objNamespace As Outlook.NameSpace Dim objSourceFolder As Outlook.MAPIFolder Dim objDestFolder As Outlook.MAPIFolder Dim objVariant As Variant Dim lngMovedItems As Long Dim intCount As Integer Dim intDateDiff As Integer Set objOutlook = Application Set objNamespace = objOutlook.GetNamespace("MAPI") Set objSourceFolder = objNamespace.GetDefaultFolder(olFolderInbox) 'Use a folder in a different data file Set objDestFolder = GetFolderPath("my-data-file-name\Inbox") For intCount = objSourceFolder.Items.Count To 1 Step -1 Set objVariant = objSourceFolder.Items.Item(intCount) DoEvents If objVariant.Class = olMail Then intDateDiff = DateDiff("d", objVariant.SentOn, Now) ' adjust number of days as needed. If intDateDiff > 60 Then objVariant.Move objDestFolder 'count the # of items moved lngMovedItems = lngMovedItems + 1 End If End If Next ' Display the number of items that were moved. MsgBox "Moved " & lngMovedItems & " messages(s)." Set objDestFolder = Nothing End Sub
Move mail you've replied to or forwarded
With a few simple changes, you can convert the macro above to move messages that were replied to or forwarded.
Begin by adding these lines to the top of the macro with the other Dim statements.
Dim lastverb, lastaction As String
Dim propertyAccessor As Outlook.propertyAccessor
Using the first macro on this page as the base, replace the code block between the If objVariant.Class... and objVariant.Move lines with the code block below. Because Reply, Reply all, and Forward values are 102, 103, and 104, and to the best of my knowledge, those are the only possible values, we can leave the lastaction value at 7 (was intDateDiff in the original macro).
If objVariant.Class = olMail Then Set propertyAccessor = objVariant.propertyAccessor lastverb = "http://schemas.microsoft.com/mapi/proptag/0x10810003" lastaction = propertyAccessor.GetProperty(lastverb) ' 102, 103, 104 are replied, forwarded, reply all If lastaction > 7 Then ' use your datafile name and each folder in the path ' the example uses an email address because Outlook 2010 ' uses email addresses for datafile names Set objDestFolder = objNamespace.Folders("diane@domain.com"). _ Folders("Inbox").Folders("completed") objVariant.Move objDestFolder
Use Case Statements instead of IF statements
This code sample uses Case statement to get the ReceivedTime or CreationTime of email, meeting requests and responses, as well as read receipt reports, then plugs the date value into the calculation. It also allows you to use different dates for each group of items types.
Sub MoveAgedItems() Dim objOutlook As Outlook.Application Dim objNamespace As Outlook.NameSpace Dim objSourceFolder As Outlook.MAPIFolder Dim objDestFolder As Outlook.MAPIFolder Dim obj As Variant Dim sDate As Date Dim sAge As Integer Dim lngMovedItems As Long Dim intDateDiff As Integer Dim intCount As Integer Set objOutlook = Application Set objNamespace = objOutlook.GetNamespace("MAPI") Set objSourceFolder = objNamespace.GetDefaultFolder(olFolderInbox) Set objDestFolder = objSourceFolder.Folders("Old") For intCount = objSourceFolder.Items.Count To 1 Step -1 Set obj = objSourceFolder.Items.Item(intCount) DoEvents Select Case obj.Class Case olMail sDate = obj.ReceivedTime sAge = 180 Case olMeetingResponseNegative, _ olMeetingResponsePositive, _ olMeetingCancellation, olMeetingRequest, _ olMeetingAccepted, olMeetingTentative sDate = obj.ReceivedTime sAge = 10 Case olReport sDate = obj.CreationTime sAge = 10 Case Else GoTo NextItem End Select intDateDiff = DateDiff("d", sDate, Now) If intDateDiff > sAge Then obj.Move objDestFolder lngMovedItems = lngMovedItems + 1 End If NextItem: Next ' Display the number of items that were moved. MsgBox "Moved " & lngMovedItems & " messages(s)." Set objDestFolder = Nothing End Sub
How to use macros
First: You will need macro security set to low during testing.
To check your macro security in Outlook 2010 or 2013, go to File, Options, Trust Center and open Trust Center Settings, and change the Macro Settings. In Outlook 2007 and older, it’s at Tools, Macro Security.
After you test the macro and see that it works, you can either leave macro security set to low or sign the macro.
Open the VBA Editor by pressing Alt+F11 on your keyboard.
To put the code in a module:
- Right click on Project1 and choose Insert > Module
- Copy and paste the macro into the new module.
More information as well as screenshots are at How to use the VBA Editor
Hi Diane,
I receive a lot of intra reports daily and they all have the same subject line, is there way to create a macro that only keeps the latest one in the inbox and moves the rest into a subfolder?
Thanks
Luke
I have a macro for that -
https://www.slipstick.com/developer/delete-older-messages-new-message-arrives/
It deletes but can just as easily move.
Hi Diane,
Excuse my ignorance however I never worked with macros at all and this will be my first time, can I kindly ask for some more help here.
Thanks
Luke
You'll use one of the macros on the other page and replace the delete with move. You also need to set the move to folder.
https://www.slipstick.com/developer/delete-older-messages-new-message-arrives/
This will move to a subfolder of the inbox.
Replace the bjowatchfolder line with this:
Dim objDestFolder As Outlook.MAPIFolder
Set objWatchFolder = objNS.GetDefaultFolder(olFolderInbox)
Set objDestFolder = objWatchFolder.Folders("foldername")
Change the delete to move
If objVariant.Subject = Item.Subject And objVariant.SentOn < Item.SentOn Then
objVariant.Move objDestFolder
Else
End If
Hi Diane,
Apologies but I do not know what I am doing here.
If I have the subject of email as 'Intra-Day' and I want to move it from inbox to a folder which the path to it is 'Inbox>>Folder>>SubFolder1>>DestinationFolder' how would the whole macro look like?
I am struggling with what I need to swap in your script.
Thanks
Luke
You can do it two ways. In one long command - not recommended because of the number of dots in the commands.(It's a VB issue with the objects)
Set objDestFolder = objWatchFolder.Folders("Folder").Folders("Subfolder").Folders("DestinationFolder")
Or split per folder. Using this method, if you were using 2 different subfolders, you would use another folder object name for the intermediary folder.
Set objDestFolder = objWatchFolder.Folders("Folder")
Set objDestFolder = objDestFolder.Folders("Subfolder")
Set objDestFolder = objDestFolder.Folders("DestinationFolder")
The screenshot shows the location of the destination folder.
More information on folder paths:
https://www.slipstick.com/developer/working-vba-nondefault-outlook-folders/
Hi Diane,
Is there a way where we can run a macro on a nightly basis where a Folder in Outlook is scanned and if the email received is older than 7 days old it, that email is forwarded to a few people for follow up?
You can use tasks and another macro to call this macro on a schedule, but outlook needs to be open for it to run.
Hi Diane,
Thank you for your prompt response. How would I do that?
Under tasks? Is there a custom macro that I need to build and would you please send me the macro code in VBA to write? or is it available through the Outlook Wizard?
If there's already another macro like this, would you please direct me to it? I've spent a very long time searching for it.
Thanks!
Hi Diane,
I need to move email based on userdefine properties available on excel
i am getting "Run time Error - 2147221233 (8004010F)" The operation Failed
while looping email from Outlook could you please help on Below code
*********************************************************************************************
Set filterItems = Folder.Items.Restrict(filterCriteria)
For Z = filterItems.Count To 1 Step -1
*** error on this Line**** Set msg = filterItems.Item(Z)
Debug.Print msg.Subject
Debug.Print msg.ReceivedTime
'
For k = 1 To InputB_Lastrow - 1
If msg.UserProperties.Find("SP ID") Is Nothing Then Exit For
If Keyword_Array(k) = "" Then Exit For
If msg.UserProperties.Find("SP ID").Value = UCase(Keyword_Array(k)) Then
' If InStr(1, UCase(msg.UserProperties.Find("SP ID")), UCase(Keyword_Array(k))) >= 1 Then
msg.Move myDestFolder
'MsgBox msg.Subject
rwcount = Sheets("Email_Moved").Range("A" & Rows.Count).End(xlUp).Offset(1, 0).Row
Sheets("Email_Moved").Range("A" & rwcount).Value = olFldr
Sheets("Email_Moved").Range("B" & rwcount).Value = msg.Subject
Sheets("Email_Moved").Range("C" & rwcount).Value = Keyword_Array(k)
' End If
End If
Next
Thanks,
Pintu.
Hi Diane any update?
Hi Diane,
Is it possible to color code mails in the inbox that have a certain age ?
I know conditional formatting allows coloring of mails that are x days old, but I need the coloring to occur when the mails are x hours old.
Is there any way to achieve this using VBA ?
Thanks,
Mario
No. You'd need to use a macro to set a category then color based on the category. (But I'm going to try a few things and see if i can get it working.)
Hello. Many thanks for this. It helped me a lot. I can now move old inbox items to folder one step above INBOX. I added macro autostart to my outlook shortcut so it is running daily with Outlook startup. If anyone would need to use folder not under Inbox (my company policy sucks...), just change the line like this and rename xxx with your folder name. ' use a subfolder under Inbox Set objDestFolder = objSourceFolder.Parent.Folders("xxx") I am now trying to do the same with Sent items. For source folder I use Set objSourceFolder = objNamespace.GetDefaultFolder(olFolderSentMail) But I got stock when I would like to move it to a sub folder undrer my "xxx" folder name archive but I failed. Could you please help me to get things right? `Dim objOutlook As Outlook.Application Dim objNamespace As Outlook.NameSpace Dim objSourceFolder As Outlook.MAPIFolder Dim objDestFolder As Outlook.MAPIFolder Dim objVariant As Variant Dim lngMovedItems As Long Dim intCount As Integer Dim intDateDiff As Integer Dim strDestFolder As String Set objOutlook = Application Set objNamespace = objOutlook.GetNamespace("MAPI") Set objSourceFolder = objNamespace.GetDefaultFolder(olFolderSentMail) ' use a subfolder under Sent objSourceFolder.Parent.Folders ("PSA documentation\Sent") For intCount = objSourceFolder.Items.Count To 1 Step -1 Set objVariant = objSourceFolder.Items.Item(intCount) DoEvents If… Read more »
So moving within the same location (such as the server) (the 1st method) work but when i try to move the mails to a different data file, an Error pops up ; "Compile Error : Sub or Function not defined". Please see attached image.
Tell me how to solve this issue please.
Hi Diane, thank you for code, ı little bit change for sent item folder. code is working but only my mail name is displaying, because of I'm sender. how can ı change/ update code for "TO" recipient "myRecipientName " am ı make wrong ? Sub sentmovedAgedMail() Dim objOutlook As Outlook.Application Dim objNamespace As Outlook.NameSpace Dim objSourceFolder As Outlook.MAPIFolder Dim objDestFolder As Outlook.MAPIFolder Dim objVariant As Variant Dim lngMovedItems As Long Dim intCount As Integer Dim intDateDiff As Integer Dim strDestFolder As String Set objOutlook = Application Set objNamespace = objOutlook.GetNamespace("MAPI") Set objSourceFolder = objNamespace.GetDefaultFolder(olFolderSentMail) For intCount = objSourceFolder.Items.count To 1 Step -1 Set objVariant = objSourceFolder.Items.Item(intCount) DoEvents If objVariant.Class = olMail Then intDateDiff = DateDiff("d", objVariant.SentOn, Now) ' I'm using 40 days, adjust as needed. If intDateDiff > 100 Then ' use your datafile name and each folder in the path ' the example uses an email address because Outlook 2010 ' uses email addresses for datafile names myRecipientName = objVariant.SentOnBehalfOfName If myRecipientName = ";" Then myRecipientName = objVariant.RecipientName End If On Error Resume Next Set objDestFolder = objSourceFolder.Folders(myRecipientName) If objDestFolder Is Nothing Then Set objDestFolder = objSourceFolder.Folders.Add(myRecipientName) End If objVariant.Move objDestFolder 'count the # of items moved lngMovedItems =… Read more »
Thanks so much Diane for this! I was looking for "VBA Macro to Move Aged Email Messages". I am looking at moving all emails ONLY from Inbox older than 22 days automatically to a folder "TO-DO/Follow Up" under the root mailbox folder parallel to Inbox (not a subfolder of Inbox). How do I set this as the destination folder?
Sorry I missed this earlier.
This does the inbox:
Set objSourceFolder = objNamespace.GetDefaultFolder(olFolderInbox)
This does the age - change it to 22
' I'm using 7 days, adjust as needed.
If intDateDiff > 22 Then
For a folder at the same level, use
Set objDestFolder = objSourceFolder.Parent.Folders("TO-DO/Follow Up")