Cut (or copy) and paste is not working at this time. The appointments need to be added to the calendar as new items, otherwise they will not sync up to the server. The macro works with individual appointments and recurring appointments but DOES NOT support Exceptions.
Although you can’t drag and drop appointments into a Group Calendar, or import a calendar ics file (or CSV) directly into a group calendar, you can add events to a group calendar in bulk using a macro.
If the appointments are in a .ics file, you'll need to import the events into an Outlook Calendar (or open the ics file as a Calendar). Do not import them into your own calendar as the macro creates a copy of everything in the source calendar into the Group Calendar and sends invites to all group members.
The second macro below created appointments using data stored in CSV files or Excel Wordbooks.
Use a Macro to Copy Appointments
This macro will copy appointments from a calendar in your mailbox (this example uses a subfolder under your calendar folder called "CopyGroups") to the group calendar and sends the meeting (which is required to add it to the group calendar and sync to the server.)
This macro does not copy exceptions (it will handle recurrences).
To use, add the appointments you need on the group calendar to a calendar folder in your mailbox then select the group calendar you want to add them to and run the macro.
Option Explicit Public Sub CopytoGroupCalendar() Dim objOL As Outlook.Application Dim objItems As Outlook.Items Dim objFolder As Outlook.Folder Dim objGroupFolder As Outlook.Folder Dim obj As Object Dim cAppt As AppointmentItem Dim moveAppt As AppointmentItem Dim strName As String Set objOL = Outlook.Application ' Calendar containing the appointments Set objFolder = Session.GetDefaultFolder(olFolderCalendar).folders("CopyGroups") Set objItems = objFolder.Items 'you are viewing the group calendar to add them to Set objGroupFolder = objOL.ActiveExplorer.CurrentFolder strName = objGroupFolder.name For Each obj In objItems Set cAppt = objGroupFolder.Items.Add(olAppointmentItem) With cAppt .Subject = obj.Subject & Format(Time, " hh:mm:ss") .Start = obj.Start .Duration = obj.Duration .Location = obj.Location .Body = obj.Body .Categories = obj.Categories .Save .Send End With If obj.IsRecurring = True Then Dim objPattern As RecurrencePattern Dim cApptPattern As RecurrencePattern Set objPattern = obj.GetRecurrencePattern Set cApptPattern = cAppt.GetRecurrencePattern cApptPattern.StartTime = objPattern.StartTime cApptPattern.EndTime = objPattern.EndTime cApptPattern.RecurrenceType = objPattern.RecurrenceType cApptPattern.PatternStartDate = objPattern.PatternStartDate cApptPattern.Interval = objPattern.Interval cApptPattern.NoEndDate = objPattern.NoEndDate cApptPattern.Duration = objPattern.Duration cApptPattern.Occurrences = cApptPattern.Occurrences If objPattern.NoEndDate = False Then cApptPattern.PatternEndDate = objPattern.PatternEndDate End If If objPattern.RecurrenceType = olRecursWeekly Then cApptPattern.DayOfWeekMask = objPattern.DayOfWeekMask End If If objPattern.RecurrenceType = olRecursMonthly Then cApptPattern.DayOfMonth = cApptPattern.DayOfMonth End If If objPattern.RecurrenceType = olRecursMonthNth Then cApptPattern.DayOfWeekMask = cApptPattern.DayOfWeekMask End If If objPattern.RecurrenceType = olRecursYearly Then cApptPattern.DayOfMonth = cApptPattern.DayOfMonth End If If objPattern.RecurrenceType = olRecursYearNth Then cApptPattern.DayOfWeekMask = cApptPattern.DayOfWeekMask End If End If cAppt.Save Next Set obj = Nothing Set objItems = Nothing Set objFolder = Nothing Set objOL = Nothing End Sub
Import From Excel
If the appointment data is stored in a CSV or Excel workbook, you can import the worksheet using this Outlook macro.
To use, open the Group Calendar you want to add the appointments to and run the macro.
The Excel version of this macro is here: "Create Appointments Using Spreadsheet Data". You'll need to identify the Group Folder using Set CalFolder = olApp.ActiveExplorer.CurrentFolder and select the Group Calendar before running the macro.
Public Sub ImportExcelToGroup() Dim olApp As Outlook.Application Dim olAppt As Outlook.AppointmentItem Dim blnCreated As Boolean Dim olNs As Outlook.NameSpace Dim CalFolder As Outlook.Folder Dim i As Long Dim xlApp As Object Dim xlWB As Object Dim xlSheet As Object Dim enviro As String Dim strPath As String On Error GoTo Err_Execute enviro = CStr(Environ("USERPROFILE")) 'the path of the workbook strPath = enviro & "\Documents\appointments.xlsx" On Error Resume Next Set xlApp = GetObject(, "Excel.Application") If Err <> 0 Then Application.StatusBar = "Please wait while Excel source is opened ... " Set xlApp = CreateObject("Excel.Application") blnCreated = True End If On Error GoTo 0 'Open the workbook to input the data Set xlWB = xlApp.Workbooks.Open(strPath) Set xlSheet = xlWB.Sheets("Sheet1") On Error Resume Next Set olApp = Outlook.Application On Error GoTo 0 Set olNs = olApp.GetNamespace("MAPI") Set CalFolder = olApp.ActiveExplorer.CurrentFolder i = 2 Do Until Trim(xlSheet.Cells(i, 1).Value) = "" Set olAppt = CalFolder.Items.Add(olAppointmentItem) With olAppt 'Define calendar item properties .Start = xlSheet.Cells(i, 5) + xlSheet.Cells(i, 6) '+ TimeValue("9:00:00") .End = xlSheet.Cells(i, 7) + xlSheet.Cells(i, 8) '+TimeValue("10:00:00") .Subject = xlSheet.Cells(i, 1) .Location = xlSheet.Cells(i, 2) .Body = xlSheet.Cells(i, 3) .BusyStatus = olBusy .ReminderMinutesBeforeStart = xlSheet.Cells(i, 9) .ReminderSet = True .Categories = xlSheet.Cells(i, 4) .Save End With i = i + 1 Loop Set olAppt = Nothing Set olApp = Nothing Set xlWB = Nothing Exit Sub Err_Execute: MsgBox "An error occurred - Exporting items to Calendar." End Sub
Delete Meetings from Group Calendar
One thing I quickly discovered when testing the macro was how tedious it is to delete events from a group calendar. Because each event is a meeting, you can't simply delete everything, you need to cancel the meetings and send the Cancelation. This macro clears the Group Calendar but does not send cancelation messages - if you need to send cancelations, you'll need to cancel each meeting "the old fashioned way".
To use, select the Group calendar you need to clear then run the macro.
Public Sub DeleteGroupMeetinga() Dim objOL As Outlook.Application Dim objItems As Outlook.Items Dim objFolder As Outlook.MAPIFolder Dim obj As AppointmentItem Dim intCount As Long Set objOL = Outlook.Application Set objFolder = objOL.ActiveExplorer.CurrentFolder Set objItems = objFolder.Items For intCount = objItems.Count To 1 Step -1 Set obj = objItems.Item(intCount) With obj .MeetingStatus = olMeetingReceivedAndCanceled .Delete End With Next Set obj = Nothing Set objItems = Nothing Set objFolder = Nothing Set objOL = Nothing End Sub
Copy and Paste (not currently working)
You need to use Cut and Paste, drag and drop doesn’t work.
- Import the ics into your calendar.
- Switch to the List view.
- Select the events then use Ctrl+X to cut (or Ctrl+C to copy).
- Switch to a List view on the group calendar.
- Use Ctrl+V to paste.
- Reset the view or switch back to the monthly view when you're finished.
If you are only moving recently imported events into the group calendar, add the modified field to the view. Turn off grouping and sort by the Modified date field. Cut or copy the appointments based on the modified time.
How to Use Macros
First: You will need macro security set to low during testing.
To check your macro security in Outlook 2010 and above, 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:
- Right click on Project1 and choose Insert > Module
- Copy and paste the macro into the new module.
More information as well as screenshots are at How to use the VBA Editor