Filtering emails in Outlook

Filtering emails in Outlook

March 19, 2016

Filtering emails by different authors is key part of the processing stage of electronic discovery.    Outlook expert Diane Poremsky has posted a very helpful macro to which will automatically move all of the emails you select in Outlook into different subfolders   - one subfolder for each sender.    


This can save you some time and avoid doing some sorting, copying, and new folder creation.   In Outlook 2016 just go to the Developer tab . . . Visual Basic, and then right click on 'ThisOutlookSession' in the Project section and insert a new module.   Save and close.  Select the emails you need to process and then go back to the Developer tab and select the macro.   New folders for each sender will be automatically created. 





Public Sub MoveSelectedMessages()

    Dim objOutlook As Outlook.Application

    Dim objNamespace As Outlook.NameSpace

    Dim objDestFolder As Outlook.MAPIFolder

    Dim objSourceFolder As Outlook.Folder

    Dim currentExplorer As Explorer

    Dim Selection As Selection

    Dim obj As Object


    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 currentExplorer = objOutlook.ActiveExplorer

    Set Selection = currentExplorer.Selection

    Set objSourceFolder = currentExplorer.CurrentFolder


    For Each obj In Selection

        Set objVariant = obj


    If objVariant.Class = olMail Then

       intDateDiff = DateDiff("d", objVariant.SentOn, Now)

         ' I'm using 40 days, adjust as needed.

       If intDateDiff > 40 Then

         sSenderName = objVariant.SentOnBehalfOfName

       If sSenderName = ";" Then

         sSenderName = objVariant.SenderName

      End If


On Error Resume Next

' Use These lines if the destination folder is not a subfolder of the current folder

' Dim objInbox  As Outlook.MAPIFolder

' Set objInbox  = objNamespace.Folders(""). _

            Folders("Inbox") ' or whereever the folder is

' Set objDestFolder = objInbox.Folders(sSenderName)


Set objDestFolder = objSourceFolder.Folders(sSenderName)


If objDestFolder Is Nothing Then

    Set objDestFolder = objSourceFolder.Folders.Add(sSenderName)

       End If

            objVariant.Move objDestFolder

            'count the # of items moved

            lngMovedItems = lngMovedItems + 1

            Set objDestFolder = Nothing

        End If

    End If




' Display the number of items that were moved.

  MsgBox "Moved " & lngMovedItems & " messages(s)."


    Set currentExplorer = Nothing

    Set obj = Nothing

    Set Selection = Nothing

    Set objOutlook = Nothing

    Set objNamespace = Nothing

    Set objSourceFolder = Nothing

End Sub

Please reload

Some elements on this page did not load. Refresh your site & try again.

Contact Me With Your Litigation Support Questions:

  • Twitter Long Shadow

© 2015 by Sean O'Shea . Proudly created with