Use this Excel macro to create appointments in different subcalendars in Outlook. To use, type the appointment data in the rows and then run the macro. The macro processes all rows that contain data in Column A, creating appointments using the data in the other columns.

To use, create a spreadsheet with the fields in this order: Calendar Name, Subject, Location, Body, Category, Start, Start Time, End, End Time, Reminder. Set Excel's VBA security to low, then paste the macro into Excel's VBA editor and run the macro.

The calendar's listed in Column A need to exist, Outlook won't create them.
 

This is an Excel macro. You'll also need to set a reference to the Outlook object model in Excel's VBA Editor's Tools, References dialog.

A version of the macro that skips previously imported events is here. A sample workbook is here.

Tip: If all appointments start and/or end at the same time, you can set a specific time value instead of getting it from the spreadsheet:

        .Start = Cells(i, 5) + TimeValue("9:00:00")
        .End = Cells(i, 7) + TimeValue("10:00:00")

Option Explicit
Public Sub CreateOutlookApptz()
   Sheets("Sheet1").Select
    On Error GoTo Err_Execute
    
    Dim olApp As Outlook.Application
    Dim olAppt As Outlook.AppointmentItem
    Dim blnCreated As Boolean
    Dim olNs As Outlook.Namespace
    Dim CalFolder As Outlook.MAPIFolder
    Dim subFolder As Outlook.MAPIFolder
    Dim arrCal As String
    
    Dim i As Long
    
    On Error Resume Next
    Set olApp = Outlook.Application
    
    If olApp Is Nothing Then
        Set olApp = Outlook.Application
         blnCreated = True
        Err.Clear
    Else
        blnCreated = False
    End If
    
    On Error GoTo 0
    
    Set olNs = olApp.GetNamespace("MAPI")
    Set CalFolder = olNs.GetDefaultFolder(olFolderCalendar)
        
    i = 2
    Do Until Trim(Cells(i, 1).Value) = ""
    arrCal = Cells(i, 1).Value
    Set subFolder = CalFolder.Folders(arrCal)
    
    Set olAppt = subFolder.Items.Add(olAppointmentItem)
         
    'MsgBox subFolder, vbOKCancel, "Folder Name"

    With olAppt
    
    'Define calendar item properties
        .Start = Cells(i, 6) + Cells(i, 7)
        .End = Cells(i, 8) + Cells(i, 9)
        .Subject = Cells(i, 2)
        .Location = Cells(i, 3)
        .Body = Cells(i, 4)
        .BusyStatus = olBusy
        .ReminderMinutesBeforeStart = Cells(i, 10)
        .ReminderSet = True
        .Categories = Cells(i, 5)
        .Save
    
    End With
                
        i = i + 1
        Loop
    Set olAppt = Nothing
    Set olApp = Nothing
    
    Exit Sub
    
Err_Execute:
    MsgBox "An error occurred - Exporting items to Calendar."
    
End Sub

Create Appointments in One Calendar

This version of the macro creates all of the appointments in one calendar. (This sample uses the default calendar.)

To use, create a spreadsheet with the fields in this order: Subject, Location, Body, Category, Start, Start Time, End, End Time, Reminder. Set Excel's VBA security to low, then paste the macro into Excel's VBA editor and run the macro.

Option Explicit
Public Sub CreateOutlookAppointments()
   Sheets("Sheet1").Select
    On Error GoTo Err_Execute
     
    Dim olApp As Outlook.Application
    Dim olAppt As Outlook.AppointmentItem
    Dim blnCreated As Boolean
    Dim olNs As Outlook.NameSpace
    Dim CalFolder As Outlook.MAPIFolder
     
    Dim i As Long
     
    On Error Resume Next
    Set olApp = Outlook.Application
     
    If olApp Is Nothing Then
        Set olApp = Outlook.Application
         blnCreated = True
        Err.Clear
    Else
        blnCreated = False
    End If
     
    On Error GoTo 0
     
    Set olNs = olApp.GetNamespace("MAPI")
    Set CalFolder = olNs.GetDefaultFolder(olFolderCalendar)
         
    i = 2
    Do Until Trim(Cells(i, 1).Value) = ""
     
    Set olAppt = CalFolder.Items.Add(olAppointmentItem)
           
    With olAppt
     
    'Define calendar item properties
        .Start = Cells(i, 5) + Cells(i, 6)
        .End = Cells(i, 7) + Cells(i, 8)
        .Subject = Cells(i, 1)
        .Location = Cells(i, 2)
        .Body = Cells(i, 3)
        .BusyStatus = olBusy
        .ReminderMinutesBeforeStart = Cells(i, 9)
        .ReminderSet = True
        .Categories = Cells(i, 4)
        .Save
' For meetings or Group Calendars
     ' .Send 
    End With
                 
        i = i + 1
        Loop
    Set olAppt = Nothing
    Set olApp = Nothing
     
    Exit Sub
     
Err_Execute:
    MsgBox "An error occurred - Exporting items to Calendar."
     
End Sub

Add or Delete Appointments from the Calendar

This version of the Excel macro will add or delete appointments in a spreadsheet. For example, it will solve this user's problem: Delete Outlook Appts with Excel sheet

Please note: this macro has the fields in a different order than the other macros on this page.

The appointments created with this macro will use the default reminder times configured in your Outlook at the time of the import.

This macro is also available in this text file.

Option Explicit
Public Sub CreateDeleteAppointments()
   ActiveSheet.Select
    On Error GoTo Err_Execute
    Dim olNs As Object 'Outlook.Namespace
    Dim olApp As Object 'Outlook.Application
    Dim olAppt As Object 'Outlook.AppointmentItem
    Dim blnCreated As Boolean
    Dim CalFolder As Object 'Outlook.MAPIFolder
     
   Dim CalItems As Object 'Outlook.Items
   Dim ResItems As Object 'Outlook.Items
   Dim sFilter, strSubject As String
   Dim itm As Object
   Dim dtStart, dtEnd As Date
   
    Dim i As Long
     
    On Error Resume Next

Set olApp = GetObject(, "Outlook.Application")
If Err.Number <> 0 Then
Set olApp = CreateObject("Outlook.Application")
  blnCreated = True
 Err.Clear
Else
blnCreated = False
End If
     
    On Error GoTo 0
     
    Set olNs = olApp.GetNamespace("MAPI")
    Set CalFolder = olNs.GetDefaultFolder(9)
    Set CalItems = CalFolder.Items
    CalItems.Sort "[Start]"
 
    i = 2
    Do Until Trim(Cells(i, 1).Value) = ""
  
If Cells(i, 7).Value = "Delete" Then

' create search string to find events to delete
    strSubject = Cells(i, 5)
    dtStart = Cells(i, 1) + Cells(i, 3)
    dtEnd = Cells(i, 2) + Cells(i, 4)
        
    'create the Restrict filter by day and recurrence"
sFilter = "[Start] = '" & dtStart & "' And [End] = '" & dtEnd & "' And [Subject] = """ & strSubject & """"

'Debug.Print sFilter

Set ResItems = CalItems.Restrict(sFilter)

'Debug.Print ResItems.Count

'Loop through the items in the collection.
For Each itm In ResItems
   itm.Delete
Next

Else

    Set olAppt = CalFolder.Items.Add(1)

    With olAppt

    'Define calendar item properties
        .Start = Cells(i, 1) + Cells(i, 3)
        .End = Cells(i, 2) + Cells(i, 4)
        .Subject = Cells(i, 5)
        '.Location = Cells(i, 2)
       ' .Body = Cells(i, 3)
If Cells(i, 7).Value = "x" Then
     .AllDayEvent = True
End If
        .BusyStatus = 2 'olBusy
       ' .ReminderMinutesBeforeStart = Cells(i, 9)
        '.ReminderSet = True
        .Categories = Cells(i, 9)
        .Save
' For meetings or Group Calendars
     ' .Send
    End With
 
    End If
        i = i + 1
        Loop
    Set olAppt = Nothing
    Set olApp = Nothing
     
    Exit Sub
     
Err_Execute:
    MsgBox "An error occurred - Exporting items to Calendar."
     
End Sub

Create Appointments in Different Time Zones

You can create the appointments in different time zones. This sample creates appointments in the default calendar from Excel data. The time zones are hardcoded. If you need to use different time zones for each appointment, add the time zone names to the spreadsheet and add the time zones like this:

  Dim timezonestart As Variant, timezoneend As Variant

i = 2
    Do Until Trim(Cells(i, 1).Value) = ""
     timezonestart = Cells(i, 12)
     timezoneend = Cells(i, 13)

     Set tzStart = olApp.TimeZones.Item(timezonestart)
     Set tzEnd = olApp.TimeZones.Item(timezoneend)

Option Explicit
Public Sub CreateOutlookApptTZ()
   Sheets("Sheet1").Select
   ' On Error GoTo Err_Execute
     
    Dim olApp As Outlook.Application
    Dim olAppt As Outlook.AppointmentItem
    Dim blnCreated As Boolean
    Dim olNs As Outlook.Namespace
    Dim CalFolder As Outlook.MAPIFolder
    Dim arrCal As String
    Dim tzStart As TimeZone, tzEnd As TimeZone
 
    Dim i As Long
         
    On Error Resume Next
 
 Set olApp = Outlook.Application
 Set tzStart = olApp.TimeZones.Item("Eastern Standard Time")
 Set tzEnd = olApp.TimeZones.Item("UTC")

    If olApp Is Nothing Then
        Set olApp = Outlook.Application
         blnCreated = True
        Err.Clear
    Else
        blnCreated = False
    End If
     
    On Error GoTo 0
     
    Set olNs = olApp.GetNamespace("MAPI")
    Set CalFolder = olNs.GetDefaultFolder(olFolderCalendar)
         
    i = 2
    Do Until Trim(Cells(i, 1).Value) = ""
    
    Set olAppt = CalFolder.Items.Add(olAppointmentItem)
           
    With olAppt
     
    'Define calendar item properties
        .StartTimeZone = tzStart
        .Start = Cells(i, 6) + Cells(i, 7)
        .EndTimeZone = tzEnd
        .End = Cells(i, 8) + Cells(i, 9)
        .Subject = Cells(i, 2)
        .Location = Cells(i, 3)
        .Body = Cells(i, 4)
        .BusyStatus = olBusy
        .ReminderMinutesBeforeStart = Cells(i, 10)
        .ReminderSet = True
        .Categories = Cells(i, 5)
        .Save
     
    End With
       
        i = i + 1
        Loop
    Set olAppt = Nothing
    Set olApp = Nothing
     
    Exit Sub
     
Err_Execute:
    MsgBox "An error occurred - Exporting items to Calendar."
     
End Sub

Create Appointment from Selected Row

This Excel macro is used to create an appointment using the data in the selected row. To use, select a cell in the row you wish to use then run the macro.

Option Explicit
Public Sub CreateOneAppointment()
    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
     
    On Error Resume Next
    Set olApp = Outlook.Application
     
    If olApp Is Nothing Then
        Set olApp = Outlook.Application
         blnCreated = True
        Err.Clear
    Else
        blnCreated = False
    End If
          
    Set olNs = olApp.GetNamespace("MAPI")
    Set CalFolder = olNs.GetDefaultFolder(olFolderCalendar)
    i = ActiveCell.Row
     
    Set olAppt = CalFolder.Items.Add(olAppointmentItem)
    With olAppt
    'Define calendar item properties
        .Start = Cells(i, 5) + Cells(i, 6)     
        .End = Cells(i, 7) + Cells(i, 8)
        .Subject = Cells(i, 1)
        .Location = Cells(i, 2)
        .Body = Cells(i, 3)
        .BusyStatus = olBusy
        .ReminderMinutesBeforeStart = Cells(i, 9)
        .ReminderSet = True
        .Categories = Cells(i, 4)
        .Save
     
    End With
                 
    Set olAppt = Nothing
    Set olApp = Nothing
           
End Sub

Send Meeting Requests

Use this macro to send meeting requests. Do not use a location if you are adding a resource.

As written for the macro below, the fields in the CSV are, left to right:
Subject
Location
Body
Categories
Start Date
Start Time
End Date
End Time
Minutes before Start
Required **
Optional **
Resource **

** Note: The attendees and resources are limited to group in this macro. to send to multiple names, you need to resolve each name. More information follows this macro.

If your CSV has the fields in a different order, change the column number in in the appointment code, for example: .Body = Cells(i, 3).

If you need to send it to multiple addresses, you'll need to use the split function then loop the attendee code to add each address separately.

Option Explicit
Public Sub CreateOutlookAppointments()
   Sheets("Sheet1").Select
    On Error GoTo Err_Execute
     
    Dim olApp As Outlook.Application
    Dim olAppt As Outlook.AppointmentItem
    Dim blnCreated As Boolean
    Dim olNs As Outlook.Namespace
    Dim CalFolder As Outlook.MAPIFolder
     
    Dim i As Long
     
    On Error Resume Next
    Set olApp = Outlook.Application
     
    If olApp Is Nothing Then
        Set olApp = Outlook.Application
         blnCreated = True
        Err.Clear
    Else
        blnCreated = False
    End If
     
    On Error GoTo 0
     
    Set olNs = olApp.GetNamespace("MAPI")
    Set CalFolder = olNs.GetDefaultFolder(olFolderCalendar)
         
    i = 2
    Do Until Trim(Cells(i, 1).Value) = ""
     
    Set olAppt = CalFolder.Items.Add(olAppointmentItem)
    With olAppt
       .MeetingStatus = olMeeting
    'Define calendar item properties
        .Subject = Cells(i, 1)
        
    ' don't use a location if using a resource
      ' .Location = Cells(i, 2)
        .Body = Cells(i, 3)
        .Categories = Cells(i, 4)
        .Start = Cells(i, 5) + Cells(i, 6)     
        .End = Cells(i, 7) + Cells(i, 8)
 
        .BusyStatus = olBusy
        .ReminderMinutesBeforeStart = Cells(i, 9)
        .ReminderSet = True

'## Start Recipient code
' get the recipients
        Dim RequiredAttendee, OptionalAttendee, ResourceAttendee As Outlook.Recipient
        Set RequiredAttendee = .Recipients.Add(Cells(i, 10).Value)
            RequiredAttendee.Type = olRequired
        Set OptionalAttendee = .Recipients.Add(Cells(i, 11).Value)
            OptionalAttendee.Type = olOptional
        Set ResourceAttendee = .Recipients.Add(Cells(i, 12).Value)
            ResourceAttendee.Type = olResource
'## End Recipient code
' For meetings or Group Calendars
' use .Display instead of .Send when testing or if you want to review before sending
        .Send
        
    End With
         
        i = i + 1
        Loop
    Set olAppt = Nothing
    Set olApp = Nothing
     
    Exit Sub
     
Err_Execute:
    MsgBox "An error occurred - Exporting items to Calendar."
     
End Sub

Send meetings to multiple addresses

In order to send a meeting to multiple addresses you need to enter the addresses in the recipient cells separated by a semicolon.

Replace the recipient code in the macro above with the code.

'## Start Recipient code
' get the recipients
    Dim objAttendee As Outlook.Recipient
    Dim arrRecipients As Variant
    Dim strRecipient As String
    Dim countRecip As Long
    Dim exCell
    Dim exRecipents
    Dim olType
 
 
 For exCell = 1 To 3
    
    Select Case exCell
     Case 1
      exRecipents = Cells(i, 10).Value
      olType = olRequired
     Case 2
      exRecipents = Cells(i, 11).Value
      olType = olOptional

     Case 3
      exRecipents = Cells(i, 12).Value
      olType = olResource

    End Select
      
    arrRecipients = Split(exRecipents, ";")
    
      If UBound(arrRecipients) >= 0 Then
      For countRecip = 0 To UBound(arrRecipients)
       strRecipient = arrRecipients(countRecip)
       Debug.Print strRecipient, countRecip, olType
               
    Set objAttendee = .Recipients.Add(strRecipient)
      objAttendee.Type = olType
      objAttendee.Resolve

      Next
    End If
Next
'## End Recipient code

How to use macros

First: You will need macro security set to low during testing.

To check your macro security in Excel 2010 or newer, go to File, Options, Trust Center and open Trust Center Settings, and change the Macro Settings.

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.

Paste the macro in Excel and run.