- From Outlook, open your macro editor. (Either press alt-F11 or select Tools, Macro, Visual Basic Editor.)
- In the macro editor window, select Insert, Module. This will create a text editor window into which you can paste the macro.
- In the text editor window, paste in the code below. (I recommend you review the code to be sure it's doing what you want.)
- You can run the code by placing your cursor anywhere in the code window between the "Sub" and "End Sub" statements and pressing F5. Optionally, you can close the Visual Basic window, then select Tools, Macro, Macros..., and "Run" RemoveDuplicateEvents.
The last section of the macro removes all items from your Deleted Items folder. I discovered this is important, because events in my Deleted Items folder "mysteriously" kept re-duplicating. Once I cleaned out the folder, my sync'ing was successful.
Here is the code for the macro. Hopefully, it is useful to someone. Please let me know if you have any problems so I can correct it. Also, I have similar macros to remove duplicate contacts and notes if anyone is interested.
':::::::::::::::::: Macro Begins Here; Copy this line and everything below 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 = 0FreeBusyStatus = 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
No questions yet.