combine 24 meeting room calendars in to 1 single list

[s7evie]

Apologies if this has been asked a 1000 times.

At work, we have 24 meeting rooms and these are on outlook as resources and people book them as and when required by using outlook. Reception can have all 24 meeting room calendars on screen but they need to have a printed list of all meetings just in case the system crashes. Currently, they spend 30 mins every day printing each calendar and then typing up a single list of meetings based on the start time.

Is there anyway to make this simpler?

 

[rst75]

It would be faster to copy the day's appointments to a master calendar for printing. Use a view that shows today's appointments, select all then copy and paste into the master calendar. Print. Delete the appointments from the master calendar and repeat the next day. A macro could speed up the copy and paste.

Or you could use a print utility, like the Calendar Printing Assistant for Outlook.

 

[Diane Poremsky]

This macro will copy appointments from a selected calendar to another calendar and adds a category for the mailbox name so you know whose calendar it is. It doesn't walk all calendars (yet), so you need to select each calendar and run it. My goal is to run it on all selected calendars in one step.

Sub CopyforPrinting()
 Dim CalFolder As Outlook.folder 
   Dim printCal As Outlook.folder 
   Dim CalItems As Outlook.Items 
   Dim ResItems As Outlook.Items 
   Dim sFilter As String 
   Dim iNumRestricted As Integer 
   Dim itm, newAppt As Object
  ' Use the selected calendar folder 
   Set CalFolder = Application.ActiveExplorer.CurrentFolder
 Set CalItems = CalFolder.Items 
   Set printCal = Session.GetDefaultFolder(olFolderCalendar).Folders("Print")
 If CalFolder = printCal Then 
   MsgBox "Can't use the same calendar for source and destination" 
   Exit Sub 
   End If
 ' Sort all of the appointments based on the start time 
   CalItems.Sort "[Start]" 
'include recurrences that fall within the date period 
   CalItems.IncludeRecurrences = True
  calName = CalFolder.Parent.Name

  'create the Restrict filter 
   sFilter = "[Start] >= '" & Date & "'" & " And [End] < '" & Date + 2 & "'"
  ' Apply the filter to the collection 
   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 
    .Start = itm.Start 
    .End = itm.End 
    .subject = itm.subject 
    .Body = itm.Body 
    .Location = itm.Location 
    .Categories = calName '& ";" & itm.Categories 
    .ReminderSet = False 
End With 
       
 newAppt.Save
  Next 
   ' Display the actual number of appointments created 
     MsgBox (iNumRestricted & " appointments were created"), vbOKOnly, "Convert Recurring Appointments"
  Set itm = Nothing 
   Set newAppt = Nothing 
   Set ResItems = Nothing 
   Set CalItems = Nothing 
   Set CalFolder = Nothing 
  
 
End Sub