Combine and Print Multiple Outlook Calendars

I'm often asked if there is a way within Outlook to print a single calendar containing the appointments from every calendar in the profile. Although Outlook doesn't have this ability built in, you could copy all of the appointments to one calendar and print, or use the Calendar Printing Assistant or third party print utilities.

Note: The calendars need to be in your profile as mailboxes, not opened as shared calendars. This will not work with shared calendars that display only Free/Busy.

Copying appointments from list view is fairly easy, if monotonous, but a macro makes quick work of it. This question on Outlook forums finally nudged me to write a macro that would do it: combine 24 meeting room calendars in to 1 single list.

The result is a set of macros pulled from macros previously published here at Slipstick. (Not a lot of writing involved!)

The macros that I tweaked to copy the appointments from the selected calendars were originally published at Select multiple calendars in Outlook and Copy Recurring Appointment Series to Appointments.

The macro deletes the calendar called Print, if it exists, then creates a new calendar folder named Print , then checks to see if one or more calendars are selected in the navigation pane, and if so, it copies the appointments to the Print calendar.

My sample copies appointments for the next 3 days, but you can add (or subtract) from Date to include any period. The data file name (as seen in the folder list) is added to each appointment as a category, so you know which calendar each appointment is from (I use category colors that match the calendar color). Recurring appointments are copied to the Print calendar as single appointments.

After running the macro, go into File, Print, click Print Options and select the Print calendar then click Print.

Note: this code was updated on July 15 2014 to create the Print calendar automatically. If the print calendar exists, it deletes it and recreates it, otherwise it creates it. It was updated on July 29 2014 to check each group for selected calendars. Updated October 27 2015 to create new items on the Print calendar instead of copying them. It's slower but avoids "copy:" added to meeting subjects and seems to work better when there are a lot of items to copy. The code is only using the subject, start and end dates from the original appointment but other fields can be added. August 25 2016: Added code to delete the Print calendar from Deleted Items (otherwise it errors if there are more than 10 Print calendars in the Deleted Items folder.)

Calendars in Exchange Public folders are categorized using "Favorites", not their actual folder name. You can include the calendar name when creating the category: calName = CalFolder.Parent.Name & "-" & CalFolder.Name

To use the macro, paste it into the VBA Editor then click in PrintCalendarsAsOne macro and click Run (F5). If you want to run it using a button on the ribbon or QAT, select the PrintCalendarsAsOne macro and add it to the ribbon or QAT.

   Dim CalFolder As Outlook.Folder
   Dim printCal As Outlook.Folder
    
' Run this macro
Sub PrintCalendarsAsOne()
    Dim objPane As Outlook.NavigationPane
    Dim objModule As Outlook.CalendarModule
    Dim objGroup As Outlook.NavigationGroup
    Dim objNavFolder As Outlook.NavigationFolder
    Dim objCalendar As Folder
    Dim objFolder As Folder
    Dim objDeletedItems As Outlook.Folder
    Dim objDeleteFolders As Outlook.folders

      
    Dim i As Integer
    Dim g As Integer
     
    On Error Resume Next
    
    Set objCalendar = Session.GetDefaultFolder(olFolderCalendar)
    Set printCal = objCalendar.folders("Print")
    printCal.Delete
    Set objDeletedItems = Session.GetDefaultFolder(olFolderDeletedItems)
    Set objDeleteFolders = objDeletedItems.folders
        objDeleteFolders.Item("Print").Delete

    Set printCal = objCalendar.folders.Add("Print")
      
    Set Application.ActiveExplorer.CurrentFolder = objCalendar
    DoEvents
      
    Set objPane = Application.ActiveExplorer.NavigationPane
    Set objModule = objPane.Modules.GetNavigationModule(olModuleCalendar)
      
  With objModule.NavigationGroups
    
    For g = 1 To .Count

    Set objGroup = .Item(g)
   
    For i = 1 To objGroup.NavigationFolders.Count
        Set objNavFolder = objGroup.NavigationFolders.Item(i)
     If objNavFolder.IsSelected = True Then
     
   'run macro to copy appt
        Set CalFolder = objNavFolder.Folder
        CopyAppttoPrint
    
    End If
    Next i
    Next g
    End With
  
  
    Set objPane = Nothing
    Set objModule = Nothing
    Set objGroup = Nothing
    Set objNavFolder = Nothing
    Set objCalendar = Nothing
    Set objFolder = Nothing
End Sub
 
 
Private Sub CopyAppttoPrint()
     
   Dim calItems As Outlook.Items
   Dim ResItems As Outlook.Items
   Dim sFilter As String
   Dim iNumRestricted As Integer
   Dim itm, newAppt As Object
 
   Set calItems = CalFolder.Items
    
   If CalFolder = printCal Then
     Exit Sub
   End If
    
' Sort all of the appointments based on the start time
   calItems.Sort "[Start]"
   calItems.IncludeRecurrences = True
 
  calName = CalFolder.Parent.name
' to use category named for account & calendar name
' calName = CalFolder.Parent.Name & "-" & CalFolder.Name
     
'create the filter - this copies appointments today to 3 days from now
   sFilter = "[Start] >= '" & Date & "'" & " And [Start] < '" & Date + 3 & "'"
  
   ' Apply the filter
   Set ResItems = calItems.Restrict(sFilter)
  
   iNumRestricted = 0
  
   'Loop through the items in the collection.
   For Each itm In ResItems
      iNumRestricted = iNumRestricted + 1
        
Set newAppt = printCal.Items.Add(olAppointmentItem)
With newAppt
   .Subject = itm.Subject
   .Start = itm.Start
   .End = itm.End
   .ReminderSet = False
   .Categories = calName
   .Save
End With

   Next
   ' Display the actual number of appointments created
    Debug.Print calName & " " & (iNumRestricted & " appointments were created")
  
   Set itm = Nothing
   Set newAppt = Nothing
   Set ResItems = Nothing
   Set calItems = Nothing
   Set CalFolder = Nothing
    
End Sub

Print Shared Calendars as One

This version of the macro works with Shared Calendars in Exchange that are open in your profile. This includes Resource calendars as well as other user's calendars. (It also works with calendars in your mailbox and in shared mailboxes open in your profile as a secondary mailbox.)

If you don't have read permission on the calendar, events will not be copied to the Print calendar.

Dim CalFolder As Outlook.Folder
 Dim printCal As Outlook.Folder
 Dim nameFolder

 ' Run this macro
 Sub PrintSharedCalendarsAsOne()
 Dim objPane As Outlook.NavigationPane
 Dim objModule As Outlook.CalendarModule
 Dim objGroup As Outlook.NavigationGroup
 Dim objNavFolder As Outlook.NavigationFolder
 Dim objCalendar As Folder
 Dim objFolder As Folder

 Dim i As Integer
 Dim g As Integer

 On Error Resume Next

 Set objCalendar = Session.GetDefaultFolder(olFolderCalendar)
 Set printCal = objCalendar.Folders("Print")
 printCal.Delete
 Set printCal = objCalendar.Folders.Add("Print")

 Set Application.ActiveExplorer.CurrentFolder = objCalendar
 DoEvents

 Set objPane = Application.ActiveExplorer.NavigationPane
 Set objModule = objPane.Modules.GetNavigationModule(olModuleCalendar)

 With objModule.NavigationGroups

 For g = 1 To .Count

 Set objGroup = .Item(g)

 For i = 1 To objGroup.NavigationFolders.Count
 Set objNavFolder = objGroup.NavigationFolders.Item(i)

 If objNavFolder.IsSelected = True Then

 'run macro to copy appt
 Set CalFolder = objNavFolder.Folder
 Set nameFolder = objNavFolder

 Dim NS As Outlook.NameSpace
 Dim objOwner As Outlook.Recipient
 Set NS = Application.GetNamespace("MAPI")
 Set objOwner = NS.CreateRecipient(nameFolder)
 objOwner.Resolve
 If objOwner.Resolved Then
 Set CalFolder = NS.GetSharedDefaultFolder(objOwner, olFolderCalendar)
 End If

 CopyAppttoPrint

 End If
 Next i
 Next g
 End With

 Set objPane = Nothing
 Set objModule = Nothing
 Set objGroup = Nothing
 Set objNavFolder = Nothing
 Set objCalendar = Nothing
 Set objFolder = Nothing
 End Sub

 Private Sub CopyAppttoPrint()

 Dim calItems As Outlook.Items
 Dim ResItems As Outlook.Items
 Dim sFilter As String
 Dim iNumRestricted As Integer
 Dim itm, newAppt As Object

 Set calItems = CalFolder.Items

 If CalFolder = printCal Then
 Exit Sub
 End If

 ' Sort all of the appointments based on the start time
 calItems.Sort "[Start]"
 calItems.IncludeRecurrences = True

 On Error Resume Next
 StrName = " - " & CalFolder.Parent.Name

 calName = nameFolder & StrName
 ' to use category named for account & calendar name
 ' calName = CalFolder.Parent.Name & "-" & CalFolder.Name

 'create the filter - this copies appointments today to 3 days from now
 sFilter = "[Start] >= '" & Date - 2 & "'" & " And [Start] < '" & Date + 3 & "'"

 ' Apply the filter
 Set ResItems = calItems.Restrict(sFilter)

 iNumRestricted = 0

 'Loop through the items in the collection.
 For Each itm In ResItems
 iNumRestricted = iNumRestricted + 1

 Set newAppt = printCal.Items.Add(olAppointmentItem)
 With newAppt
 .Subject = itm.Subject
 .Start = itm.Start
 .End = itm.End
 .ReminderSet = False
 .Categories = calName
 .Save
 End With

 Next
 ' Display the actual number of appointments created
 Debug.Print calName & " " & (iNumRestricted & " appointments were created")

 Set itm = Nothing
 Set newAppt = Nothing
 Set ResItems = Nothing
 Set calItems = Nothing
 Set CalFolder = Nothing

 End Sub
 

Utilities to Print Multiple Calendars

If you prefer using a utility, the following utilities can print multiple calendars together on one page.
 

How to use macros

First: You will need macro security set to low during testing.

To check your macro security in Outlook 2010 or 2013, go to File, Options, Trust Center and open Trust Center Settings, and change the Macro Settings. In Outlook 2007 and older, it’s at Tools, Macro Security.

After you test the macro and see that it works, you can either leave macro security set to low or sign the macro.

Open the VBA Editor by pressing Alt+F11 on your keyboard.

To put the code in a module:

1. Right click on Project1 and choose Insert > Module
2. Copy and paste the macro into the new module.

More information as well as screenshots are at How to use the VBA Editor