Macro to Delete Duplicate items in Outlook calendar where title is the same and date is the same

[Howardc1001]

I have various items in my outlook Calendar



Where the title is the same for e.g. Sales Returns for MJR Distributors to be summitted within 30 days of the due date and the date set in the calendar is 24/07/2024 (dd/mm/yyyy) , I want to retain one of the items with the same title and delete the balance using VBA

I have tried to write code but none of the duplicates are being deleted whilst retaining only one of the items that are the same

Kindly amend my code

 Sub RemoveDuplicateAppointments()
    Dim olApp As Outlook.Application
    Dim olNamespace As Outlook.NameSpace
    Dim olFolder As Outlook.Folder
    Dim olItems As Outlook.Items
    Dim olItem As Object
    Dim dict As Object
    Dim key As String
    Dim specificDate As Date
    Dim startDate As String
    Dim endDate As String
    Dim deleteItems As Collection
    Dim item As Object
    Dim deleteCount As Integer
    
    ' Get the specific date from the user
    On Error Resume Next
    specificDate = InputBox("Enter the specific date (dd/mm/yyyy):", "Remove Duplicates")
    If Err.Number <> 0 Or specificDate = 0 Then
        MsgBox "Invalid date format. Please enter the date in dd/mm/yyyy format.", vbExclamation
        Exit Sub
    End If
    On Error GoTo 0
    
    ' Format the date as yyyy-mm-dd for filtering
    startDate = Format(specificDate, "yyyy-mm-dd") & " 00:00"
    endDate = Format(specificDate + 1, "yyyy-mm-dd") & " 00:00"
    
    ' Initialize Outlook objects
    Set olApp = New Outlook.Application
    Set olNamespace = olApp.GetNamespace("MAPI")
    Set olFolder = olNamespace.GetDefaultFolder(olFolderCalendar)
    Set olItems = olFolder.Items
    
    ' Restrict items to the specific date
    olItems.Sort "[Start]"
    olItems.IncludeRecurrences = True
    Set olItems = olItems.Restrict("[Start] >= '" & startDate & "' AND [Start] < '" & endDate & "'")
    
    ' Initialize dictionary to track unique titles and dates
    Set dict = CreateObject("Scripting.Dictionary")
    Set deleteItems = New Collection
    
    ' Loop through items to find duplicates based on Title and Date
    For Each olItem In olItems
        If TypeOf olItem Is Outlook.AppointmentItem Then
            ' Combine title and date (ignoring time) as key
            key = olItem.Subject & "|" & Format(olItem.Start, "dd/mm/yyyy")
            If dict.exists(key) Then
                ' This is a duplicate item, mark it for deletion
                deleteItems.Add olItem
            Else
                ' Add to dictionary to track unique title and date combinations
                dict.Add key, True
            End If
        End If
    Next olItem
    
    ' Delete duplicate items
    deleteCount = 0
    For Each item In deleteItems
        item.Delete
        deleteCount = deleteCount + 1
    Next item
    
    ' Clean up
    Set olItem = Nothing
    Set dict = Nothing
    Set deleteItems = Nothing
    Set olItems = Nothing
    Set olFolder = Nothing
    Set olNamespace = Nothing
    Set olApp = Nothing
    
    MsgBox deleteCount & " duplicate items removed for " & Format(specificDate, "dd/mm/yyyy"), vbInformation
End Sub

I have also posted on Macro to Delete Duplicate items in Outlook calendar where title is the same and same date