combine 24 meeting room calendars in to 1 single list

Discussion in 'Using Outlook' started by s7evie, May 16, 2014.

  1. s7evie


    New Member
    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?
  2. 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.
  3. Diane Poremsky

    Diane Poremsky

    Senior Member
    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.

    Code (Text):
    Copy Source
    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
       ' 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

Share This Page