Match Subjects

[BillFromMA]

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

[BillFromMA]

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
Dim FolderItems 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.GetDefaultFolder(olFolderInbox)


Set FolderItems = Folder.Items


'Sorts messages so the most recent is kept
FolderItems.Sort "ReceivedTime"


'Get the count of the number of emails in the folder
n = FolderItems.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 the first 13 characters of the subject, which contain Ticket followed by the number
Message = Left(FolderItems(i).Subject, 13)


'Only for web helpdesk tickets
If Left(FolderItems(i).Subject, 7) = "Ticket " Then


'Check a dictionary variable for a match
If Items.Exists(Message) = True Then
'If the item has previously been added then delete this duplicate
FolderItems(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


End If


Next i


ExitSub:


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


End Sub


Here is the solution, if anyone else runs across this thread.