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 Object
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 olItem.SenderName = "Web Help Desk" Then
If olDict.Exists(Left(olItem.Subject, 13) & olItem.SenderName) Then
'if the subject exists test to see which message is newer
If olItem.ReceivedTime > olDict(Left(olItem.Subject, 13) & olItem.SenderName) Then
olInbox.Items(olItem.Subject).Move olDupe
olDict.Remove Left(olItem.Subject, 13) & olItem.SenderName
olDict.Add Left(olItem.Subject, 13) & olItem.SenderName, olItem.ReceivedTime
Else
' move the current item if it is older
olItem.Move olDupe
End If
Else
olDict.Add Left(olItem.Subject, 13) & olItem.SenderName, olItem.ReceivedTime
End If
End If
End If
Next
Set olDict = Nothing
Set olSession = Nothing
End Sub
I'm trying to match subjects on the first 13 characters (this contains a unique ticket number), keeping all other functions of this the same. I've added the Left(olItem.Subject, 13) in several spots, but it doesn't seem to work correctly. Can someone please look over the code and let me know what I can change?
Thanks!
Bill