How to Auto Merge All Appointments & Meetings from All Calendars with Outlook VBA

If you want to always merge all the appointments and meetings from all calendars into one calendar for convenient check, you can apply the method introduced in this article.

Perhaps you have many email accounts configured in your Outlook. In this case, you must have many calendars in your Outlook. Therefore, every time when you want to check how many appointments there are today, you have to switch to all the calendars. It will be a bit troublesome. So, why don’t you merge them into one calendar? In the followings, we will expose a piece of VBA code, which can realize it with ease.

Auto Merge All Appointments & Meetings from All Calendars

1. At the very outset, launch your Outlook application.
2. After you enter the main Outlook window, press “Alt + F11” key buttons.
3. Then you will get into the “Microsoft Visual Basic for Applications” window.
4. Next you need to find and open the “ThisOutlookSession” project.
5. Subsequently, you ought to copy and paste the following VBA codes into this project window.

'Here we take two calendars as an example - "Calendar A" & "Calendar B"
'You can add more as per your needs
Dim WithEvents objACalendarItems As Outlook.Items
Dim WithEvents objBCalendarItems As Outlook.Items
Dim objDefaultCalendar As Outlook.Folder
 
Private Sub Application_Startup()
    Set objACalendarItems = Application.Session.folders("File A").folders("Calendar").Items
    Set objBCalendarItems = Application.Session.folders("File B").folders("Calendar").Items

    'Here we merge into the default calendar
    Set objDefaultCalendar = Application.Session.GetDefaultFolder(olFolderCalendar)
End Sub
 
Private Sub objACalendarItems_ItemAdd(ByVal Item As Object)
    Call CopyToDefaultCalendar(Item)
End Sub

Private Sub objBCalendarItems_ItemAdd(ByVal Item As Object)
    Call CopyToDefaultCalendar(Item)
End Sub

Private Sub CopyToDefaultCalendar(ByVal objItem As Object)
    Dim objCopiedAppointment As Outlook.AppointmentItem
    Dim objMoviedAppointment As Outlook.AppointmentItem
    Dim strPSTFileName As String
 
    Set objCopiedAppointment = objItem.Copy
    Set objMoviedAppointment = objCopiedAppointment.Move(objDefaultCalendar)
 
    strPSTFileName = objItem.parent.parent.Name
 
    'Tag the source of the copied appointments
    objMoviedAppointment.Categories = "From " & strPSTFileName
    objMoviedAppointment.Save
    'If want to delete it from the original calendar, add the following line:
    'objItem.Delete
End Sub

6. After that, you need to assign a digital certificate to the current macro.
7. Later go to “macro settings” to permit the digitally signed macros.
8. Eventually, you can restart your Outlook program to activate the new macro.
9. From now on, every time when any new appointment or meeting is added in the non-default calendars, it’ll be auto copied to the default calendar, like the following screenshot:

Remove Overdue Items from Calendar in Time

As we know, Outlook is more prone to various errors when the mailbox becomes larger and larger. Therefore, it is suggested to remove useless items from mailbox in time, such as overdue appointments and meetings. In the meantime, it is better if you keep a potent repair tool nearby, such as DataNumen Outlook Repair. It can repair Outlook issues without breaking a sweat.

Author Introduction:

Shirley Zhang is a data recovery expert in DataNumen, Inc., which is the world leader in data recovery technologies, including sql recovery and outlook repair software products. For more information visit www.datanumen.com