As I receive quite a few emails with the same subject line from VBA Express, is there a macro I can run which will delete all the older messages with duplicate subject lines, leaving only the newest?
MD
PS I have never attempted Outlook macros.
As I receive quite a few emails with the same subject line from VBA Express, is there a macro I can run which will delete all the older messages with duplicate subject lines, leaving only the newest?
MD
PS I have never attempted Outlook macros.
Hi Malcom
I had a crack at this below, the code moves the older messages into a subfolder called "Old". I'm wary whether the code always moves the correct old message with this line
olInbox.Items(olItem.Subject).Move olDupe
In my testing it worked but.....
The code uses a Dictionary Object to hold the subject name and sender (so it wont cull messages from different senders with the same subject). I've used early binding so you need to set a reference to Microsoft Scripting Runtime.
I think that the Find method would be a superior way of doing this speedwise, I'll have a play
Cheers
Dave
Sub KillDupes() 'Needs a reference to Microsoft Scripting Runtime Dim olSession As Outlook.Application, olNamespace As NameSpace Dim olInbox As Outlook.MAPIFolder, olDupe As Outlook.MAPIFolder Dim olItem As MailItem Dim olDict As Dictionary Set olSession = New Outlook.Application Set olDict = New Scripting.Dictionary Set olNamespace = olSession.GetNamespace("MAPI") Set olInbox = olNamespace.GetDefaultFolder(olFolderInbox) On Error Resume Next Set olDupe = olInbox.Folders("Old") If Err <> 0 Then Set olDupe = olInbox.Folders.Add("Old") On Error GoTo 0 For Each olItem In olInbox.Items If TypeName(olItem) = "MailItem" Then If olDict.Exists(olItem.Subject & olItem.SenderName) Then 'if the subject exists test to see which message is newer If olItem.ReceivedTime > olDict(olItem.Subject & olItem.SenderName) Then olInbox.Items(olItem.Subject).Move olDupe olDict.Remove olItem.Subject & olItem.SenderName olDict.Add olItem.Subject & olItem.SenderName, olItem.ReceivedTime Else ' move the current item if it is older olItem.Move olDupe End If Else olDict.Add olItem.Subject & olItem.SenderName, olItem.ReceivedTime End If End If Next Set olDict = Nothing Set olSession = Nothing End Sub
Last edited by Aussiebear; 04-04-2023 at 01:03 AM. Reason: Adjusted the code tags
Thanks Dave,
It works a treat on Inbox, but I commonly have one level of sub-folder within inbox so I've tweaked your code to the following:
Sub KillDupes() 'Needs a reference to Microsoft Scripting Runtime Dim olSession As Outlook.Application, olNamespace As NameSpace Dim olInbox As Outlook.MAPIFolder, olDupe As Outlook.MAPIFolder Dim MyolInbox As Outlook.MAPIFolder Dim olItem As MailItem Dim olDict As Dictionary Dim MS MySubs = Array("EE", "VBA") Set olSession = New Outlook.Application Set olDict = New Scripting.Dictionary Set olNamespace = olSession.GetNamespace("MAPI") Set olInbox = olNamespace.GetDefaultFolder(olFolderInbox) For Each MS In MySubs Set MyolInbox = olInbox.Folders(MS) On Error Resume Next Set olDupe = olInbox.Folders("Old") If Err <> 0 Then Set olDupe = olInbox.Folders.Add("Old") On Error GoTo 0 For Each olItem In MyolInbox.Items If TypeName(olItem) = "MailItem" Then If olDict.Exists(olItem.Subject & olItem.SenderName) Then 'if the subject exists test to see which message is newer If olItem.ReceivedTime > olDict(olItem.Subject & olItem.SenderName) Then MyolInbox.Items(olItem.Subject).Move olDupe olDict.Remove olItem.Subject & olItem.SenderName olDict.Add olItem.Subject & olItem.SenderName, olItem.ReceivedTime Else ' move the current item if it is older olItem.Move olDupe End If Else olDict.Add olItem.Subject & olItem.SenderName, olItem.ReceivedTime End If End If Next Next Set olDict = Nothing Set olSession = Nothing End Sub
Last edited by Aussiebear; 04-04-2023 at 01:06 AM. Reason: Adjusted the code tags
Hi MD,
Error msg ' Variables not defined ' appear for this line when I run your marco for a another layer of sub folder.
[VBA]Dim MS
My Subs = Array ("EE", "VBA")[/VBA]
Would appreciate your guide on this line
Thanks
Our Greatest Glory is not in never falling, but in rising every time we fall
There is great satisfaction in building good tools for others to use
Malcolm,
Did it always move the older message? I'm not sure if the code needs a sort routine or not. Please note this change
as the inbox may contain meeting requests, voicemail etcDim olItem As MailItem should be Dim olItem As Object
Cheers
Dave
Last edited by Aussiebear; 04-04-2023 at 01:06 AM. Reason: Adjusted the code tags
Hi Dave,Originally Posted by brettdj
I am new to macros so please bear with my lack of knowledge on the subject. The code is great and is exactly what I need for a makeshift inventory system I have set up for my small business utilizing QR codes and a smart phone to email the information. Sometimes the code works perfectly but sometimes the newer message is moved to the "old" folder. Any suggestions on how to fix this would be greatly appreciated.
Thank you very much,
Gene
Hi Dave,
It works fine. With the change I made, I only have emails in the two designated folders, but a useful filter anyway.
Thanks
Malcolm
This is the second time I've tried posting here.
I guess I pushed the wrong button the first time.
Option Explicit Private Sub RemoveDuplicateSubjectSender() 'Needs a reference to Microsoft Scripting Runtime 'Needs a reference to Microsoft Outlook object library if not run in Outlook Dim i As Long Dim MyolInbox As Outlook.MAPIFolder Dim olInbox As Outlook.MAPIFolder Dim olNamespace As Outlook.NameSpace Dim olSession As Outlook.Application Dim strMailFolders() As String ReDim strMailFolders(1) strMailFolders(0) = "EE" strMailFolders(1) = "VBA" Set olSession = New Outlook.Application Set olNamespace = olSession.GetNamespace("MAPI") Set olInbox = olNamespace.GetDefaultFolder(olFolderInbox) On Error Resume Next RemoveDuplicates olInbox With olInbox For i = 0 To UBound(strMailFolders) Set MyolInbox = .Folders(strMailFolders(i)) If Err.Number = 0 Then RemoveDuplicates MyolInbox Else Err.Clear End If Next i End With olSession.Quit Set MyolInbox = Nothing Set olInbox = Nothing Set olNamespace = Nothing Set olSession = Nothing End Sub Private Sub RemoveDuplicates(MyolInbox As Outlook.MAPIFolder) Dim olDict As Scripting.Dictionary Dim olDupe As Outlook.MAPIFolder ' Dim olItem As Outlook.MailItem Dim olItem As Object Dim strSubjectSender As String Set olDict = New Scripting.Dictionary On Error Resume Next Set olDupe = MyolInbox.Folders("Old") With Err If .Number <> 0 Then Set olDupe = MyolInbox.Folders.Add("Old") .Clear End If End With For Each olItem In MyolInbox.Items With olItem strSubjectSender = .Subject & .SenderName If TypeName(olItem) = "MailItem" Then If olDict.Exists(strSubjectSender) Then 'if the subject exists test to see which message is newer If .ReceivedTime > olDict(strSubjectSender) Then MyolInbox.Items(.Subject).Move olDupe olDict.Remove strSubjectSender olDict.Add strSubjectSender, .ReceivedTime Else ' move the current item if it is older .Move olDupe End If Else olDict.Add strSubjectSender, .ReceivedTime End If End If End With Next Set olDict = Nothing Set olDupe = Nothing Set olItem = Nothing End Sub
Last edited by Aussiebear; 04-04-2023 at 01:11 AM. Reason: Adjusted the code tags
Hi Howard,
I saw your earlier posting, now superceded by this one. I think you should reinstate your comments as to what this revised coding does.
MD
MVP (Excel 2008-2010)
Post a workbook with sample data and layout if you want a quicker solution.
To help indent your macros try Smart Indent
Please remember to mark threads 'Solved'
Hi MD
Using the above cause Outlook to prompt a security msg stating that a program is trying to gain access to the address book, is there a way to do
away this security msg.
Thanks
Our Greatest Glory is not in never falling, but in rising every time we fall
There is great satisfaction in building good tools for others to use
I don't believe so
http://www.vbaexpress.com/forum/showthread.php?t=7847
MVP (Excel 2008-2010)
Post a workbook with sample data and layout if you want a quicker solution.
To help indent your macros try Smart Indent
Please remember to mark threads 'Solved'
Originally Posted by mdmackillop
I have a look at the link provided, and removing New Outlook works in
Set olsession = New Outlook.Application
Thanks
Last edited by Aussiebear; 04-04-2023 at 01:12 AM. Reason: Adjusted the code tags
Our Greatest Glory is not in never falling, but in rising every time we fall
There is great satisfaction in building good tools for others to use
See what happens when I don't use Option Explicit!
Should beI had two sub-folders within "Inbox", EE & VBA.Dim MS, MySubs MySubs = Array("EE", "VBA")
Last edited by Aussiebear; 04-04-2023 at 01:12 AM. Reason: Adjusted the code tags
MVP (Excel 2008-2010)
Post a workbook with sample data and layout if you want a quicker solution.
To help indent your macros try Smart Indent
Please remember to mark threads 'Solved'
MD, Excellent!!
Thanks
Our Greatest Glory is not in never falling, but in rising every time we fall
There is great satisfaction in building good tools for others to use
Hi, I got compile error on line
Dim olDict As Dictionary
Error is 'User-defined type not defined'.
I have outlook 2000, any thoughts.
Hi Skasu,
Welcome to VBAX
Did you notice this line?
Regards
MD
[vba] 'Needs a reference to Microsoft Scripting Runtime[/vba]
MVP (Excel 2008-2010)
Post a workbook with sample data and layout if you want a quicker solution.
To help indent your macros try Smart Indent
Please remember to mark threads 'Solved'
I have tried to search Outlooks own help and I'll go on Google after I've posted this, but...obvious Noobie here...what is "Microsoft Scripting Runtime", how do you create a reference to it and what is the effect?Originally Posted by mdmackillop
Last edited by Aussiebear; 04-04-2023 at 01:13 AM. Reason: Adjusted the code tags
I think in hindsight the problem was in my coding.
Own question answered, GIMF... http://msdn.microsoft.com/en-us/libr...ffice.10).aspxOriginally Posted by Asterix
I think in hindsight the problem was in my coding.
Code works fine but in my case I'm looking to remove older emails from a shared groupbox, displayed like this...
- Mailbox - Thegaul, Asterix
Archive
Deleted Items
Drafts
Inbox
Junk E-mail
Outbox
Sent Items
Search Folders
- Mailbox - Groupbox, Our
Deleted Items
Inbox
Outbox
Sent Items
Search Folders
It's the "- Mailbox - Groupbox, Our", "Inbox" that I want to remove the older emails from. Any idea how I can modify this code to do this?
I think in hindsight the problem was in my coding.
Ok, this code works but in my case, I'm not looking to remove older emails in *my* inbox. I'm looking to remove older emails in a group mailbox which I can see like this...
[quote]
Mailbox - Thegaul, Asterix
I think in hindsight the problem was in my coding.