Operating system:: Windows 11
Outlook version: Office 2021
Email type or host: POp
Outlook version: Office 2021
Email type or host: POp
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
It would be appreciated if someone could either amend my code or provide code to do this
I have also cross posted -see below
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
It would be appreciated if someone could either amend my code or provide code to do this
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 cross posted -see below
Macro to Delete Duplicate items in Outlook calendar where title is the same and date is the same
Macro to Delete Duplicate items in Outlook calendar where title is the same and date is the same Outlook
www.msofficeforums.com