Importing Calendar Items to Outlook (VBA/Excel)

AddThis Social Bookmark Button

Microsoft Outlook includes an import/export feature that can be used to create calendar items from a spreadsheet. This method however only works on your primary mailbox.

If you have direct access to your shared mailboxes or exchange server there are other solutions but as a user this makes it difficult to automatically create calendar items in a shared mailbox. Looking for a solution I discovered an easy way to create a VBA macro that could be used to select and create calendar items in any of my mailboxes. Simply populate this spreadsheet and run the import and you can watch as calendar items are created and meeting requests automatically sent.

 

The VBA code is quite simple and shown below. You can also download the attached Macro Enabled Excel Workbook for Excel 2007/2010/2013 to test this out. To assist in debugging you can uncomment the additional lines to provide notification prompts as each value is selected. Sample data is included in the spreadsheet to show usage.

Dim iRow
Dim iProcessed
Dim iAdded
iRow = 5
iProcessed = 0
iAdded = 0
Dim OLApp As Object
Dim OLNSF As Object
Dim OLAppointment As Object
On Error Resume Next
Set OLApp = GetObject(, "Outlook.Application")
If OLApp Is Nothing Then Set OLApp = CreateObject("Outlook.Application")
On Error GoTo 0
If Not OLApp Is Nothing Then
Set OLNSF = OLApp.GetNamespace("MAPI").PickFolder
If Not OLNSF Is Nothing Then
While Cells(iRow, 1) <> ""
If Cells(iRow, 2) <> "" Then
Set OLAppointment = OLNSF.Items.Add
'MsgBox "1"
OLAppointment.Subject = Cells(iRow, 1).Value
'MsgBox "2-3"
OLAppointment.Start = FormatDateTime(Cells(iRow, 2).Value, vbShortDate) & " " & FormatDateTime(Cells(iRow, 3).Value, vbLongTime)
'MsgBox "4-5"
OLAppointment.End = FormatDateTime(Cells(iRow, 4).Value, vbShortDate) & " " & FormatDateTime(Cells(iRow, 5).Value, vbLongTime)
'MsgBox "6"
OLAppointment.AllDayEvent = CBool(Cells(iRow, 6).Value)
'MsgBox "7"
OLAppointment.Body = Cells(iRow, 7).Value
'MsgBox "8"
OLAppointment.Location = Cells(iRow, 8).Value
'MsgBox "9"
OLAppointment.Categories = Cells(iRow, 9).Value
'MsgBox "10"
OLAppointment.RequiredAttendees = Cells(iRow, 10).Value
'MsgBox "11"
OLAppointment.OptionalAttendees = Cells(iRow, 11).Value
'MsgBox "12"
If Cells(iRow, 12).Value = 1 Then OLAppointment.MeetingStatus = 1
'MsgBox "13"
OLAppointment.ResponseRequested = CBool(Cells(iRow, 13).Value)
OLAppointment.Send
OLAppointment.Save
iAdded = iAdded + 1
End If
iProcessed = iProcessed + 1
iRow = iRow + 1
Wend
MsgBox iProcessed & " records processed and " & iAdded & " appointments created."
End If
End If
Set OLAppointment = Nothing
Set OLNSF = Nothing
Set OLApp = Nothing
Attachments:
Download this file (OutlookImport.xlsm)OutlookImport.xlsm20 kB2015-04-09