Sub CopyAppointments()

Dim objOutlook
Dim objNameSpace
Dim objCalendarFolderSrc
Dim objCalendarFolderDest
Dim objItemsSrc
Dim objItemsDest
Dim ObjApptsSrc
Dim intMode

Const olFolderCalendar = 9
Const olAppointmentItem = 1

Set objOutlook = CreateObject(“Outlook.application”)
Set objNameSpace = objOutlook.GetNamespace(“MAPI”)

MsgBox “Choose the source calendar”
Set objCalendarFolderSrc = objNameSpace.PickFolder
If objCalendarFolderSrc = Null Then End

While objCalendarFolderSrc.DefaultItemType olAppointmentItem
MsgBox “You did not select a calendar. Try again.”
Set objCalendarFolderSrc = objNameSpace.PickFolder
If objCalendarFolderSrc = Null Then End

Wend

MsgBox “Choose the destination calendar”
Set objCalendarFolderDest = objNameSpace.PickFolder
If objCalendarFolderSrc = Null Then End

While objCalendarFolderDest.DefaultItemType olAppointmentItem
MsgBox “You did not select a calendar. Try again.”
Set objCalendarFolderDest = objNameSpace.PickFolder
If (objCalendarFolderDest Is Nothing) Then End
Wend

Set objItemsSrc = objCalendarFolderSrc.Items
Set objItemsDest = objCalendarFolderDest.Items
Dim x
Dim i
intMode = 5
If objItemsDest.Count < 1 Then
intMode = 4

If (intMode = 4) Then
For x = 1 To objItemsSrc.Count
Set ObjApptsSrc = objItemsSrc.Item(x).Copy
ObjApptsSrc.Move objCalendarFolderDest
Next
End If

If (intMode = 5) Then
For x = 1 To objItemsSrc.Count
For i = objItemsDest.Count To 1 Step -1
If objItemsSrc.Item(x).Start = objItemsDest.Item(i).Start Then
objItemsDest.Item(i).Delete
Set objItemsDest = objCalendarFolderDest.Items
End If
Next
Next

For x = 1 To objItemsSrc.Count
Set ObjApptsSrc = objItemsSrc.Item(x).Copy
ObjApptsSrc.Move objCalendarFolderDest
Next
End If
End If

MsgBox “Complete.”
Set objNameSpace = Nothing
Set objOutlook = Nothing
Set objCalendarFolderSrc = Nothing
Set objCalendarFolderDest = Nothing
Set objItemsSrc = Nothing
Set objItemsDest = Nothing
Set ObjApptsSrc = Nothing

End Sub