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) If Trim(Cells(i, 11).Value) = "" Then 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 Cells(i, 11) = "Imported" End If i = i + 1 Loop Set olAppt = Nothing Set olApp = Nothing ThisWorkbook.Save Exit Sub Err_Execute: MsgBox "An error occurred - Exporting items to Calendar." End Sub