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.
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) '+ TimeValue("9:00:00")
.End = Cells(i, 8) + Cells(i, 9) '+TimeValue("10:00:00")
.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) '+ TimeValue("9:00:00")
.End = Cells(i, 7) + Cells(i, 8) '+TimeValue("10:00:00")
.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
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) '+ TimeValue("9:00:00")
.EndTimeZone = tzEnd
.End = Cells(i, 8) + Cells(i, 9) '+TimeValue("10:00:00")
.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) '+ TimeValue("9:00:00")
.End = Cells(i, 7) + Cells(i, 8) '+TimeValue("10:00:00")
.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.
The fields, left to right, are
Subject
Location
Body
Categories
Start Date
Start Time
End Date
End Time
Minutes before Start
Required (limited to one person or group)
Optional (limited to one person or group)
Resource (limited to one person or group)
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)
' doni use location if using a resource
' .Location = Cells(i, 2)
.Body = Cells(i, 3)
.Categories = Cells(i, 4)
.Start = Cells(i, 5) + Cells(i, 6) '+ TimeValue("9:00:00")
.End = Cells(i, 7) + Cells(i, 8) '+TimeValue("10:00:00")
.BusyStatus = olBusy
.ReminderMinutesBeforeStart = Cells(i, 9)
.ReminderSet = True
' 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
' 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
How to use macros
First: You will need macro security set to low during testing.
To check your macro security in Excel 2010 or 2013, 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.
To put the code in a module:
- Right click on VBAProject and choose Insert > Module
- Copy and paste the macro into the new module.
Leave a Reply
304 Comments on "Create Appointments Using Spreadsheet Data"
to account for blank fields, either use on error resume next or check for blanks:
if Cells(i, 12).Value "" then
Set OptionalAttendee = .Recipients.Add(Cells(i, 12).Value)
OptionalAttendee.Type = olOptional
end if
To add multiples, you can try entering the addresses in the cell, seperated by a semi-colon. I don't recall if i tested it, so it may not work. If not, you'd need to convert to the cell value to an array and loop through the names. (not tested, so i may have mistyped something)
dim myarray
arrAddresses = Cells(i, 12).Value
myarray=split(arrAddresses,";")
For i = LBound(myarray) To UBound(myarray)
Set OptionalAttendee = .Recipients.Add(myarray(i))
OptionalAttendee.Type = olOptional
Next i
Hi Diane,
I have looked to use your code to generate appointments from excel in a shared outlook calendar. The challenge I have is that I, as the creator of the calendar see the reminder pop up, but my colleagues who I share the calendar with do not.
Any suggestions on how all persons who have editing rights to the shared calendar can receive appointment reminders, regardless of who run the macro to create the appointments?
Regards,
Antony
unfortunately, there is no good solution. You'd need to copy the events to your calendar to get a reminder... otherwise, you'd need to use macros to send email reminders to everyone.
Are you creating it on his calendar as shared calendar or is he going to run it himself and wants the events on a Calendar named Test?
This sets the folder and is what you'd change. This specific example is the default calendar.
Set CalFolder = olNs.GetDefaultFolder(olFolderCalendar)
This is a subfolder of the default:
Set CalFolder = olNs.GetDefaultFolder(olFolderCalendar).Folders("calendar name")
this is a folder at the same level (as seen in the folder list (Ctrl+6), not in the calendar navigation pane)
Set CalFolder = olNs.GetDefaultFolder(olFolderCalendar).Parent.folders("calendar name")
A shared calendar needs a bit more code - i have an example at
Hi Diane,
Is it possible to upload to a Shared Calendar if I am set-up as an Editor on that Calendar?
Also - is it possible for the upload not to be duplicated?
You should be able to create and import events... and no, outlook doesn't check for duplicate events.
Diane,
Thank you very much for this code. It helps tremendously! What if you need to add a bunch of information to the body, not just one cell. In my situation, I need to add an itinerary to the body. I am creating the itinerary on a separate worksheet in the same workbook. Any suggestions? Like many others looking at this code, I am a newbee. Any help is greatly appreciated.
Adding it to the body should work -
strItinerary = Sheets("Sheet2").Range("A1:B6")
.Body = Cells(i, 4) & strItinerary
Diane,
Thank you for your response. How do I define strItinerary? If I define it as a string, I get a type mismatch. If it is a range, I get a RTE 91 Object variable or with block variable not set. Thank you again for your help.
Sorry I missed this, i wanted to test it but haven't had time (and am taking a shaort vacation now).
Try using just Dim:
Dim strItinerary
Not working for me, the debugger stops at this: Set subFolder = CalFolder.Folders(arrCal)
That means the Subfolder under Calendar does not exist. If you aren't using subfolders, try Set subFolder = CalFolder - this way you won't need to edit the code too much.
Thank you, that corrected the problem and it worked once, the second time I tried it nothing was created in the calendar, then I get a run-time error 462: The remote server machine does not exist or is unavailable. If I download a new example workbook and make the change to the Subfolder under calendar, it will work 1 time only. If that makes sense.
That doesn't make sense... i'll take a look. In the meantime, it's possible it's due to the olapp code. It may need to be changed to
set olApp = GetObject(,"Outlook.Application")
but first, add Set olNs = Nothing before the olapp = nothing line and see if it works.
Hello Diane,
Thanks so much for the code! I'm using the code here to skip previously imported appointment here: https://www.slipstick.com/macros/excel-save-calendar-macro.txt. It's the first time I'm using macros or VBA, so I have no useful knowledge of either. I'm running Outlook and Excel 2016.
When I try to run the code, I get "run-time error 91: Object variable or With block variable not set." The debugger highlights "Set olNs = olApp.GetNamespace ("MAPI")
Any suggestions?
oh... did you set a reference to the outlook object library in tools, references?
is olApp set as application? (Its in the code, so it should be).
Try changing that to application:
Set olNs = Application.GetNamespace ("MAPI")
Thanks for the suggestion. This results in Run-time error 438: "Object doesn't support this property or method." Same line of code.
oh... did you set a reference to the outlook object library in tools, references?
I did. I have been wondering if that might be the issue, but I have the reference set and I can't find another object library in the list for Outlook.
for most people there is only one outlook object library - the number will change depending on your version.
You're using the exact code? Did you add any other fields? (its not erroring here.)
Firstly, this is a wonderful code and does exactly what I need with one exception. The dates that I want to use are actually a formula based from the original date. If original date is May 1, 2017 the notification date is set for 4 months later. I think it is having trouble reading the formula instead of the displayed date but I can't figure out how to correct this. Any suggestions?
So its reading the formula, not the value? Try adding value to the cell : Cells(i, 6).value