How do I remove duplicate appointments in outlook?

  • Thread starter Thread starter Guest
  • Start date Start date
G

Guest

I have synchronised my pda with outlook after my computer had been repaired
and for some reason it has duplicated most, but not all, of my appointments.
I can see a remove duplicates instruction for contacts, but not for
calendars. How can I do this?
 
Hello!
I Have made a VBA Script to remove duplicate appointments in Outlook:

Public Sub Delete_Duplicate_Appointments()
' Delete duplicate appointments

Const olFolderCalendar = 9

Set myOlApp = CreateObject("Outlook.Application")
Set myNameSpace = myOlApp.GetNamespace("MAPI")
Set myFolder = myNameSpace.GetDefaultFolder(olFolderCalendar)
Set myItems = myFolder.Items

'Sort the calendar database
Dim strTri
strTri = ""
strTri = strTri & "[Start]"
strTri = strTri & "[End]"
strTri = strTri & "[Subject]"
strTri = strTri & "[Body]"
strTri = strTri & "[AllDayEvent]"
strTri = strTri & "[Sensitivity]"

myItems.Sort strTri

'Delete successive equal appointments

Dim lastStr, Str, nbrDelete
lastStr = ""

nbrDelete = 0
For Each Item In myItems

Str = ""
Str = Str & vbCrLf & Item.Start
Str = Str & vbCrLf & Item.End
Str = Str & vbCrLf & Item.Subject
Str = Str & vbCrLf & Item.Body
Str = Str & vbCrLf & Item.AllDayEvent
Str = Str & vbCrLf & Item.Sensitivity

Str = Replace(Str, vbCrLf & vbCrLf, vbCrLf)
Str = Replace(Str, vbCrLf & vbCrLf, vbCrLf)
Str = Replace(Str, vbCrLf & vbCrLf, vbCrLf)
Str = Replace(Str, vbCrLf & vbCrLf, vbCrLf)
Str = Replace(Str, vbCrLf & vbCrLf, vbCrLf)

If Str = lastStr Then
Item.Delete
nbrDelete = nbrDelete + 1
End If
lastStr = Str
Next

MsgBox "Nbr appointments deleted : " & nbrDelete

End Sub

Good luck!
 
Back
Top