Need:
Do you have the need to delete duplicate emails from Microsoft Outlook? Perhaps you have accidentally created hundreds of duplicates, and your pst file is so vast you do not have the time nor the energy to remove each of them manually. In this case it would be nice to have an Excel Macro that would do it for you, all with the click of a button. Well that is possible, thank you to Jacob. Simply use the code below which was written by Jacob Hilderbrand – Microsoft Excel MVP, to do the grunt work for you. Simply drop into Excel and run. Or download the Microsoft Excel workbook from our website, and run it from there.

Purpose:
The purpose of the following macro is to delete duplicate emails from an Outlook folder. This can occur if multiple imports from PST files have occurred, or if you receive emails from different email accounts and end up getting CC’ed on multiple accounts.
If you do not keep your emails organized it can eventually get out of control.

Functionality Summary:
The macro will process all emails in a specified folder and compare the subject and body to the other emails in the same folder. Duplicate emails are then deleted leaving only one unique copy of each email in the folder.

Process:
The macro is setup in an Excel workbook for simplicity. The macro can be run by clicking the button on the worksheet.

Code:

Option Explicit

‘Set a reference to the Microsoft Scripting Runtime from Tools, References.

Sub DeleteDuplicateEmails()

Dim i As Long
Dim n As Long
Dim Message As String
Dim Items As New Dictionary
Dim AppOL As Object
Dim NS As Object
Dim Folder As Object

‘Initialize and instance of Outlook
Set AppOL = CreateObject(“Outlook.Application”)

‘Get the MAPI Name Space
Set NS = AppOL.GetNamespace(“MAPI”)

‘Allow the user to select a folder in Outlook
Set Folder = NS.PickFolder

‘Get the count of the number of emails in the folder
n = Folder.Items.Count

‘Check each email starting from the last and working backwards to 1
‘Loop backwards to ensure that the deleting of the emails does not interfere with subsequent items in the loop
For i = n To 1 Step -1
‘Load the matching criteria to a variable
‘This is setup to use the Sunject and Body, additional criteria could be added if desired
Message = Folder.Items(i).Subject & “|” & Folder.Items(i).Body

‘Check a dictionary variable for a match
If Items.Exists(Message) = True Then
‘If the item has previously been added then delete this duplicate
Folder.Items(i).Delete
Else
‘In the item has not been added then add it now so subsequent matches will be deleted
Items.Add Message, True
End If
Next i

ExitSub:

‘Release the object variables from memory
Set Folder = Nothing
Set NS = Nothing
Set AppOL = Nothing

End Sub

Local Microsoft Excel and Access experts

Have questions? Post them here as comments and we will get back with you.

Written by Jacob Hilderbrand, Microsoft Excel MVP.