How to Remove Duplicates in Outlook Calendar

I am sure many have done this before: You ran a sync from Google to Outlook or Outlook to your Mobile Phone or something..  and your Outlook creates a duplicate of EVERY event in your calendar.. here is the script to fix it.


1. Go to Outlook Calendar
2. ALT+F11
3. Insert -> Module
4. Paste the following code in:

Sub RemoveDuplicateEvents()
    Dim olApp As Outlook.Application
    Dim olAppointment1 As Outlook.AppointmentItem
    Dim olAppointment2 As Outlook.AppointmentItem
    Dim olItems As Outlook.Items
    Dim olDeletedItems As Outlook.Items
    Dim olNS As Outlook.NameSpace
    Dim SkipConfirmation As Boolean


    Set olApp = New Outlook.Application
    Set olNS = olApp.GetNamespace("MAPI")
    Set olItems = olNS.GetDefaultFolder(olFolderCalendar).Items
    Set olDeletedItems = olNS.GetDefaultFolder(olFolderDeletedItems).Items

    olItems.Sort ("Subject")
    olItems.Sort ("Start")
    Dim DeleteCount As Integer
    Dim z As Integer
    Dim FreeBusyStatus As Boolean
    DeleteCount = 0

    FreeBusyStatus = MsgBox("Do you want to set the status for all-day events to 'Free'?", vbYesNo, "Set Free Busy Status") = vbYes
    If FreeBusyStatus Then
        SkipConfirmation = Not MsgBox("Do you want to be prompted to set free times for all-day events?", vbYesNo, "Skip Confirmation?") = vbYes
    End If

    For z = olItems.Count To 2 Step -1
        If Not (Len(olItems.Item(z).Subject) = 36 And InStr(1, olItems.Item(z), " ") > 0) And _
            Not (Len(olItems.Item(z - 1).Subject) = 36 And InStr(1, olItems.Item(z - 1), " ") > 0) Then

             Set olAppointment1 = olItems.Item(z)
             Set olAppointment2 = olItems.Item(z - 1)
             Debug.Print olAppointment1.Subject & vbCrLf & olAppointment2.Subject
             DoEvents
        
             With olAppointment1
                 If .Subject = olAppointment2.Subject And _
                         .Start = olAppointment2.Start Then
                     .Delete
                     Debug.Print "Calendar item " & Left(olAppointment2.Subject, 25) & "..." & " deleted"
                     DeleteCount = DeleteCount + 1
                 End If
             End With
             With olAppointment2
                 If .AllDayEvent And .BusyStatus <> olFree And FreeBusyStatus Then
                     If Not SkipConfirmation Then
                         If MsgBox("Do you want to set """ & .Subject & """ as free time?", vbYesNo, "Confirm Status Change") = vbYes Then
                             .BusyStatus = olFree
                             .Save
                             Debug.Print .Subject & " updated!"
                         End If
                     Else
                         .BusyStatus = olFree
                         .Save
                         Debug.Print .Subject & " updated!"
                     End If
                 End If
             End With
        End If
    Next
    If MsgBox(DeleteCount & " duplicate Outlook calendar items have been removed." & _
        vbCrLf & "Do you want to clear your deleted items folder?" & vbCrLf & _
        "(This must be done to prevent re-syncing 'deleted' entries)", vbYesNo, "Confirm Deleted Items Removal") = vbYes Then
        ' Clear deleted items folder
        For z = olDeletedItems.Count To 1 Step -1
            olDeletedItems.Item(z).Delete
            DoEvents
        Next
    End If
    MsgBox "Cleanup Complete!", vbOKOnly, "End of Processing"

End Sub

':::::::::::::::::: Macro Ends Here


Did that work for you? let us know if it did.


If you have the same thing for removing duplicate Outlook emails.. I would love to know.