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.