How to remove duplicate calendar events from Lookout


  1. From Outlook, open your macro editor. (Either press alt-F11 or select Tools, Macro, Visual Basic Editor.)
  2. In the macro editor window, select Insert, Module. This will create a text editor window into which you can paste the macro.
  3. 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.)
  4. 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


With olAppointment1

If .Subject = olAppointment2.Subject And _

.Start = olAppointment2.Start Then


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


Debug.Print .Subject & " updated!"

End If


.BusyStatus = olFree


Debug.Print .Subject & " updated!"

End If

End If

End With

End If


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




End If

MsgBox "Cleanup Complete!", vbOKOnly, "End of Processing"

End Sub

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

No questions yet.