This macro "watches" for a new appointment to be added to the calendar and copies it to a second calendar. This is useful if you are sharing a calendar or syncing one calendar with a smartphone.

The code contains and If - Then statement (If Item.BusyStatus = olBusy Then) and copies only items that are marked busy. You can use use Categories or keywords in the subject as the filter or copy all items by removing the If.. and Then lines. You can remove or change the "Copied" tag added to the subject line.

This code, as written, assumes the second calendar is in another data file in the profile. It can easily be changed to work with a folder in the current data file. See Working with VBA and non-default Outlook Folders for more information.

To use:

1. Enable macros in the Trust Center. In Outlook 2010/2013, this is at File, Options, Trust Center, Macros. In Outlook 2007, go to Tools, Trust Center. Use either warn or no security for now. Once you are happy with it, you can sign it with a self-certificate and set macros to signed-only.
2. Open the VB Editor by pressing Alt+F11 on your keyboard.
3. Expand Project1 to display ThisOutlookSession and double click to open it to the right side.
4. Paste the code below into ThisOutlookSession. I have a text file with the macros here: Text file containing the macros to copy, change, and delete appointments.
5. Change the folder path ("display name in folder list\Calendar") to the display name you see in the Folder List (this is usually the email address in Outlook 2010 and 2013). For example, the path shown in these screenshots is "New PST\Test Cal".
   
   You can see the parent path in the Folder List (Ctrl+6) or right-click on the Calendar folder and choose Properties when in the Calendar module. The path can be copied from the Properties page, which can be helpful for nested folders or long names.
   
6. Place the mouse in the Application_StartUp macro and press the Run button or F5.
7. Create an appointment in your calendar and see if it was copied to the other calendar.

May 17 2019: Replaced code that searched on GUID to use GetDATETIME function instead as the GUID function is blocked due to security updates.

If you prefer to use a random alphanumeric code instead of the GUID, use the last code sample at Create sequential numbers or random character keywords for the necessary VBA code and update the macro accordingly.

September 22 2017: changed the code to copy all appointments except those marked Free. It previously only copied Busy appt.)

Dim WithEvents curCal As Items
Dim newCalFolder As Outlook.folder
 
Private Sub Application_Startup()
   Dim NS As Outlook.NameSpace
   Set NS = Application.GetNamespace("MAPI")
' calendar to watch for new items
   Set curCal = NS.GetDefaultFolder(olFolderCalendar).Items
' calendar moving copy to
   Set newCalFolder = GetFolderPath("data-file-name\calendar")
   Set NS = Nothing
End Sub
  
Private Sub curCal_ItemAdd(ByVal Item As Object)
Dim cAppt As AppointmentItem
Dim moveCal As AppointmentItem
 
' On Error Resume Next

' copy all but appt marked Free
' remove to make a copy of all items
If Item.BusyStatus <> olFee Then
 
 
   Item.Body = Item.Body & "[" & GetDATETIME & "]"
   Item.Save
   
Set cAppt = Application.CreateItem(olAppointmentItem)

With cAppt
    .Subject = "Copied: " & Item.Subject
    .Start = Item.Start
    .Duration = Item.Duration
    .Location = Item.Location
    .Body = Item.Body
End With
 
' set the category after it's moved to force EAS to sync changes
 Set moveCal = cAppt.Move(newCalFolder)
 moveCal.Categories = "moved"
 moveCal.Save
 
    End If
 End Sub

Public Function GetDATETIME() As String
   GetDATETIME = Format(DateTime.Now, "yyyy-MM-dd hh:mm:ss")
End Function

Function GetFolderPath(ByVal FolderPath As String) As Outlook.Folder
    Dim oFolder As Outlook.Folder
    Dim FoldersArray As Variant
    Dim i As Integer
        
    On Error GoTo GetFolderPath_Error
    If Left(FolderPath, 2) = "\\" Then
        FolderPath = Right(FolderPath, Len(FolderPath) - 2)
    End If
    'Convert folderpath to array
    FoldersArray = Split(FolderPath, "\")
    Set oFolder = Application.Session.Folders.Item(FoldersArray(0))
    If Not oFolder Is Nothing Then
        For i = 1 To UBound(FoldersArray, 1)
            Dim SubFolders As Outlook.Folders
            Set SubFolders = oFolder.Folders
            Set oFolder = SubFolders.Item(FoldersArray(i))
            If oFolder Is Nothing Then
                Set GetFolderPath = Nothing
            End If
        Next
    End If
    'Return the oFolder
    Set GetFolderPath = oFolder
    Exit Function
        
GetFolderPath_Error:
    Set GetFolderPath = Nothing
    Exit Function
End Function

This code was submitted by Anshu Nahar, He made some changes to ItemAdd and ItemChange; so now this works for recurring items as well, including all exceptions.

Private Sub curCal_ItemAdd(ByVal Item As Object)
    Dim cAppt As AppointmentItem
    Dim movecal As AppointmentItem
    
    On Error Resume Next
    
    Item.Mileage = "$NCDTH1$" & GetUniqueId
    Item.Save
    
    Set cAppt = Item.Copy
    cAppt.Categories = "Copied"
    cAppt.Move newCalFolder
    
 End Sub
  
Private Sub curCal_ItemChange(ByVal Item As Object)
    Dim cAppt As AppointmentItem
    Dim objAppointment As AppointmentItem
    Dim targetItems As Outlook.Items
       
       
    On Error Resume Next
      
    strMileage = Item.Mileage
    
    Set targetItems = newCalFolder.Items
    targetItems.Sort (Mileage)
    
    For Each objAppointment In targetItems
        If objAppointment.Mileage = strMileage Then
            Set cAppt = objAppointment
            cAppt.Delete
            Set cAppt = Item.Copy
            cAppt.Categories = "Copied"
            cAppt.Move newCalFolder
        End If
     Next
     
End Sub

Copy to a Shared Exchange Calendar

When the calendar you want to copy to or from is in a shared Exchange mailbox, you need to resolve the owner's name or alias and pass it to GetSharedDefaultFolder. You can use the alias, default SMTP address, or display name. I recommend using the alias or email address.

Replace the Application_Startup macro in this text file with the version here.

Private Sub Application_Startup()
  Dim NS As Outlook.NameSpace
  Dim CalendarFolder As Outlook.Folder
  Dim objOwner As Outlook.Recipient
  
  Set NS = Application.GetNamespace("MAPI")
   ' default calendar
Set curCal = NS.GetDefaultFolder(olFolderCalendar).Items

   'calendar you are copying to
Set objOwner = NS.CreateRecipient("maryc")
    objOwner.Resolve
     

 If objOwner.Resolved Then
   'MsgBox objOwner.Name

  Set newCalFolder = NS.GetSharedDefaultFolder(objOwner, olFolderCalendar)
  Set Items = newCalFolder.Items
 End If

End Sub

Update copied appointment

If you want to update appointments on the second calendar, add this code sample to the module. This code looks for an appointment with the same GUID. When you save changes, the matching event is also updated.

Because this code looks for the GUID, you can change the subject or start time.

This code is written to work with the ItemAdd macros above and gets the newCalFolder name from the application_startup macro.

 
Private Sub curCal_ItemChange(ByVal Item As Object)
Dim cAppt As AppointmentItem
Dim objAppointment As AppointmentItem
Dim strBody As String    
 On Error Resume Next
      
' use 2 + the length of GetDATETIME string
strBody = Right(Item.Body, 21)
 
For Each objAppointment In newCalFolder.Items
 If InStr(1, objAppointment.Body, strBody) Then
         Set cAppt = objAppointment
   End If
 Next

With cAppt
    .Subject = "Copied: " & Item.Subject
    .Start = Item.Start
    .Duration = Item.Duration
    .Location = Item.Location
    .Body = Item.Body
    .Save
End With
  
End Sub

Delete the copied appointment

When you delete the original appointment, the following code will delete the copy as well. Thanks to Adrian for this!

This code watches the deleted items folder for deleted appointments. It gets the newCalFolder name from the application_startup macro.

You'll need to add lines to the top of ThisOutlookSession and Application_Startup.

Updated January 26 2016 to watch the deleted items folder for deleted appointments instead of using the Remove event.

'At top of ThisOutlookSession:
Dim WithEvents DeletedItems As Items

'In Application_Start macro:
Set DeletedItems = NS.GetDefaultFolder(olFolderDeletedItems).Items

Private Sub DeletedItems_ItemAdd(ByVal Item As Object)
' only apply to appointments
If Item.MessageClass <> "IPM.Appointment" Then Exit Sub
' if using a category on copied items, this may speed it up.
If Item.Categories = "moved" Then Exit Sub
 
Dim cAppt As AppointmentItem
 Dim objAppointment As AppointmentItem
 Dim strBody As String
 
On Error Resume Next
 
' use 2 + the length of the GetDATETIME string
 strBody = Right(Item.Body, 21)
 If Left(strBody, 1) <> "[" Then Exit Sub

For Each objAppointment In newCalFolder.Items
 If InStr(1, objAppointment.Body, strBody) Then
 Set cAppt = objAppointment
 cAppt.Delete
 End If
 Next
 
 End Sub