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 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
        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
         
If itm.IsRecurring Then
  Set newAppt = ActiveExplorer.CurrentFolder.Items.Add(olAppointmentItem)
  With newAppt
  
  .Start = itm.Start
  .End = itm.End
  .Subject = itm.Subject & " (Copy)"
  .Body = itm.Body
  .Location = itm.Location
  .Categories = calName
  .ReminderSet = False
  .Save
  End With
  
Else

Set newAppt = itm.Copy
newAppt.Categories = calName
End If
 
newAppt.Move printCal
 
   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