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
294 Comments on "Create Appointments Using Spreadsheet Data"
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
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
Hi Diane,
Your code is very useful however, is there a way for the appointment to originate from someone else's email account by way of allowing the user to enter their username into a MsgBox linked to a Cell?
This is because the file I created will sit in my OneDrive on Office 365 and will open with my user details attached.
Thank you
The owner or organizer should be the account in the Outlook profile, regardless of where it is stored - so no need to enter a name.
This was really very helpful. It took me a bit of time to figure everything out and use the macro (my first time using it), but your instructions made it simple and it worked beautifully. It will save me a lot of time in the future!
Hello,
I am trying to create PTO form for my company and would like the supervisor to then be able to schedule it as a meeting on the Human Resources calendar with the press of a macro button.
I am pointing the relevant fields to Sheet 1, which I have set-up according to the instruction. When I try to run the macro I get a compile error:
"user defined types not defined" and
" Dim olApp As Outlook.Application" is highlighted.
Do you have any suggestions as to what I may have done wrong?
Thank you so much for any help. If I can get this to work, it will save a lot of time.
Mike
This:
"user defined types not defined" and
" Dim olApp As Outlook.Application" is highlighted.
means you did not set a reference in the VBA editor's Tools, References for the Microsoft Outlook object library.