A client had many duplicates in one folder and while there are a number of duplicate remover utilities, any of which work great if you need to check multiple folders for duplicates, he just needed to check one folder. He didn't want to install a utility but there were too many duplicates to manually remove them.
The solution: a macro that moves duplicate messages to a subfolder for review.
This macro is slow. If you have a lot of messages in the folder, expect it to take some time to run. See Duplicate Remover Tools for third party utilties.
To use, select a folder that needs checked for duplicates and run the macro. The macro will create a subfolder named Duplicates and move the duplicate messages to it. After reviewing the duplicates, delete the folder.
Public Sub MoveDuplicates()
Dim objOL As Outlook.Application
Dim objFolder As Outlook.MAPIFolder
Dim objDupFolder As Outlook.MAPIFolder
Dim objDictionary As Object
Dim i As Long
Dim objItem As Object
Dim strKey As String
Set objOL = Outlook.Application
Set objDictionary = CreateObject("scripting.dictionary")
Set objFolder = objOL.ActiveExplorer.currentFolder
On Error Resume Next
Set objDupFolder = objFolder.Folders.Item("Duplicates")
If objDupFolder Is Nothing Then
Set objDupFolder = objFolder.Folders.Add("Duplicates")
End If
For i = objFolder.Items.count To 1 Step -1
Set objItem = objFolder.Items.Item(i)
'Only check email items type
If InStr(1, objItem.MessageClass) <> "IPM.Schedule" Then
strKey = objItem.Subject & "," & objItem.Body & "," & objItem.SentOn
strKey = Replace(strKey, ", ", Chr(32))
If objDictionary.Exists(strKey) = True Then
objItem.Move objDupFolder
' use this to delete immediately
' objItem.Delete
Else
objDictionary.Add strKey, True
End If
End If
Next i
End Sub
How to use the macros on this page
First: You need to have macro security set to the lowest setting, Enable all macros during testing. The macros will not work with the top two options that disable all macros or unsigned macros. You could choose the option Notification for all macros, then accept it each time you restart Outlook, however, because it's somewhat hard to sneak macros into Outlook (unlike in Word and Excel), allowing all macros is safe, especially during the testing phase. You can sign the macro when it is finished and change the macro security to notify.
To check your macro security in Outlook 2010 and newer, go to File, Options, Trust Center and open Trust Center Settings, and change the Macro Settings. In Outlook 2007 and older, look 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.
The macros on this page should be placed in a module.
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
More Information
See Duplicate Remover Tools for third party utilities that will be somewhat faster and have more features.
SC SC SC says
Thanks! it works great for my own inbox, but I have several shared mailboxes attached to my outlook. How can I made the Macro run on these 'other' added inboxes too?
Thanks in advance!
SC
Diane Poremsky says
This line: Set objFolder = objOL.ActiveExplorer.currentFolder Means it runs on the selected folder.
It creates the duplicate folder as a subnfolder of the selected folder, so it should work on any folder in any mailbox.
SC SC SC says
Oh right, my bad. Is there a way it can be run in at the "mailbox level" which automatically applies to all subfolders within the mailbox, or does it only work when run within each folder?
Diane Poremsky says
It's per-folder - mostly because it is slow and inefficient. If you need to do multiple folders, use a commerical product such as Relief jet.
https://www.slipstick.com/addins/duplicates-addins/duplicate-remover-tools-for-outlook/
Helmer Aslaksen says
Thanks!!! Just what I needed! You saved me a lot of work! You're my hero! And thanks for also explaining what the Outlook clean up function does.
Bikram singhary says
There are some tips for Outlook Delete Duplicate Emails ;
Diane Poremsky says
Clean up was not designed to remove duplicates - it cleans up redundant messages in threads. For example, if you have a long thread back and forth with each person quoting the messages in full, all messages in the thread except for the last one will be cleaned up.
David Pierson says
Hi, Thank you this is just what I was looking for.
Puzzled by the line
because Instr normally takes two string arguments after the start position.
InStr([ start ], string1, string2, [ compare ])
Thanks again.
Diane Poremsky says
This should also work -
If looking for true -
if InStr(1, objItem.MessageClass, "IPM.Schedule")
if looking for not true -
If InStr(1, objItem.MessageClass, "IPM.Schedule") = 0 Then
Amit says
below message appears whenever i try to run it:
user-defined type not defined
Diane Poremsky says
if you click debug, which line does it stop on? That error usually means a reference to another object model is not set, but this macro doesn't use other references.
Gonzalo says
Hello, your code works amazingly.
Do you think it's possible that instead of moving duplicates to a new folder to have them marked/labeled with a color tab to be able to visually check the detected duplicates before deleting them?
You are a life saver
Diane Poremsky says
Sure. Change this line:
objItem.Move objDupFolder
to
objItem.categories = "duplicate"
Nasser says
hello, is it possible to edit it to delete the duplicated message from the inbox instead of the subfolder (keep the message in the subfolder safe)
Diane Poremsky says
It's moving the dupe to the subfolder - you can delete it instead.
If objDictionary.Exists(strKey) = True Then
objItem.Move objDupFolder
' use this to delete immediately
' objItem.Delete
Else
Dixit says
Copied/Pasted, worked like a charm. Thx a lot
Yogesh D. Khebde says
Hi Diane,
Im Yogesh and i work as an Business analyst - hence i keep recieving a lot of automated reports from our different sources - and i have set rusel for all of them to be seggregated and moved to different folders - however some times there are emails / reports with same subject line and sender that get moved to multiple different folders (obviously because of the rules i set in incorrect order - which i must admit im lazy to fix) . hence i was checking if i can get a macro to check all folders and its subfolders for the emails with same Subject - Time - Sender & Body and delete any of them - the macro is BBOOS here to decide.
Im Ok with any 1 copy staying there for my reference.
is it possible ? or am i asking for too much from a macro ..!
thanks a ton for the current one too ...!
Diane Poremsky says
it would be very slow to check all folders - an addin would be more efficient - still slow, but faster because its complied.
Neris says
Hi, The outlook 2016 32bit crashes when I try to run this code! Any idea? Thanks
Diane Poremsky says
No error messages, it just crashes? Does it process some message before crashing? How many messages are in the folder?
Ben Watson says
Thank you, I've used your tutorials over the years and they are always very helpful!
Jose Grande says
comes up as an empty string, and as such, it fails to find real duplicates.
Timothy Dollimore says
Hi
This is great. Its just chopped a folder of messages in half for me, so thanks.
But :-) I think this should also check for attachments being the same. If you have two copies of a message and one of them has had the attachments removed, the current code will move one of the copies to the duplicates folder (potentially the one with the attachment). And if you don't notice :-(
I tried adding the 'Attachments' attribute to the comparison, but that didn't distinguish between a message with attachment, and a copy of the message with the attachment deleted.
So, instead I opted for LastModificationTime
strKey = objItem.Subject & "," & objItem.Body & "," & objItem.SentOn & "," & objItem.LastModificationTime
Some minor testing undertaken, the worst case scenario if you add this extra thing to the key that is built is that some messages won't be deleted (that you might consider duplicates)
fffffffrrf says
Thx bande de bitches de vos meres les sac a foutre qui se font trouer le cul sur le trottoir
Hazem briki says
hi , i really like your work and that help me a lot i want to customize your code to depend of my needs but i stucked ,
1 st how can i excute this macro in a specefic folder not in current folder
2nd how can i remove the duplicated mails but it depend on time
for exemple :
if
input : 3 mails same body (the time between 3 mails is less than 30 minutes)
output: 1 mail in folder and 2 in the duplicates folder
if
input : 3 mails same body ( the time between 3 mails is more than 30 minutes)
output : 3 mails in the folder and 0 in the duplactes folder
i hope you can anwser my question and thank you a lot
Johannes Czernin says
My Outlook Journal folder does contain a fair number of duplicates. Would it bei possible to modify this script to get rid of these duplicates?
Diane Poremsky says
It should work - you need to change this line
If InStr(1, objItem.MessageClass) <> "IPM.Schedule" Then
to
If InStr(1, objItem.MessageClass) <> "IPM.Activity" Then
You need to change the Senton field to start
objItem.SentOn
Johannes Czernin says
Hi, Diane, you're great! Throughout the years, with a number of program updates, hard disk replacements and computer breakdowns, I had assembled no less than 23.400 Journal entries.
First I tried your code, in a separate .pst file, on 32 entries and within seconds 27 of them were sorted out as duplicates. Then I went the whole way and gave it the go on the full directory. After slightly more than two hours exactly 9.065 of them had been removed as duplicates.
Thanks a lot for your great help, and best wishes from Vienna, Austria,
Johannes
Diane Poremsky says
You're welcome!
Thanks for mentioning how longi t takes- i knew it was slow if there were a lof of items ot checl - but never timed it.
Robin Kaspersen says
Hi Diane, I am trying to use this VBA. Which works great. However, I wan tit to remove the oldest of the duplicates and keep the newest addition. As it is now it is deleting the newest and keeping the old. How can I change this to delete the old and keep the newest added?
Diane Poremsky says
It's seeing the oldest first, so it gets added to the dictionary first. You could try changing the sort order, but I don't think it will help. Changing the count won't help because you need it stepping backwards.
I was going to suggest changing the modified date of each after
If objDictionary.Exists(strKey) = True Then
but i don't think that would work since its using a 'dictionary'. You'd need to add the modified field to this line
strKey = objItem.Subject & "," & objItem.Body & "," & objItem.SentOn
then check it, but offhand, I don't know how since the date isn't being saved as a date.
So... if changing the sort order doesn't help, i dont know of a way to do it. Sorry. :(
Robin Kaspersen says
Thanks for the feedback. It does not seem sort helps when using (i).
I tried to see if the sorting could work by using the following VBA below.
It works with this, but it does not check all the duplicates and remove, only a selected handfull (like 3-4 cases). I need it do check the entire calendar and delete the oldest in 1 run.
Sub RemoveDuplicateItems()
Dim objDictionary As Object
Dim i As Long
Dim objItem As Object
Dim strKey As String
Dim objFolder As Folder
Dim objItems As Outlook.Items
Set objDictionary = CreateObject("scripting.dictionary")
'Select a source folder
Set objFolder = Outlook.Application.Session.PickFolder
Set objItems = objFolder.Items
objItems.Sort "[CreationTime]", True
For Each objItem In objItems
Select Case objItem.Class
'Check appointment subject
Case olAppointment
strKey = objItem.Subject
End Select
strKey = Replace(strKey, ", ", Chr(32))
'Remove the duplicate items
If objDictionary.Exists(strKey) = True Then
objItem.Delete
Else
objDictionary.Add strKey, True
End If
Next objItem
End Sub
Johannes Czernin says
Hi, Diane,
Due to some malware I had to completely re-install my system with Win10 and Office 365, the latter in the 64-bit version instead of the 32-bit one I had been sing before. When I had everything working properly I tried to run your MoveDuplicates macro but as soon as I had pressed the F5 button a message box popped up with the information that "... macros in this object are disactivated…"
Disabling all Trust Center restrictions has not helped at all. Proceeding to every bit of information and hints I could find by a Google search was in vain. Most of these tips on the Net just repeat the original Outlook "Help" function whilst those that do not are crap as they are citing text formulated for older versions of Office.
My faith in your Guru capability is endless so please could you once more help me out with some advice?
Thanks a lot for any help and kind regards,
Johannes
Diane Poremsky says
It should work to set macro security to low (at least temporarily, then use selfcert and sign it and go back to signed macros) - but you do need to restart outlook for it to go into effect.