Over the last few weeks the company that I work for have been migrating from Google Apps over to Microsoft 365 for mail/calendar/contacts and unified messaging etc. This has not been without it’s challenges. Some have which have been fairly bizarre. This week I was approached by a member of our department who had somehow managed to end up with 10,000+ appointments of the same title in his calendar. We set about trying to remove them on mass using the Outlook GUI, but soon realised this would take a very long time. Which is when I put together the following snippet of VBA:
NB: This code ‘takes no prisoners, and straight deletes the appointments matching the criteria you pass it. This wouldn’t be easy to undue if you ran with incorrect parameters. I’d advise adding a break point and testing a few before letting it hit your entire calendar folder.
Dim myNameSpace As NameSpace Dim myCalendar As Folder Dim myAppts As Items Dim myAppt As AppointmentItem Dim i As Integer Sub purge_cal() Set myNameSpace = Outlook.Application.GetNamespace("MAPI") Set myCalendar = myNameSpace.GetDefaultFolder(olFolderCalendar) Set myAppts = myCalendar.Items i = 0 For Each myAppt In myAppts If myAppt.Subject = "" Then i = i + 1 Debug.Print "Deleting " & myAppt.Subject myAppt.Delete End If Next Debug.Print i & " calendar items deleted" End Sub