Import dates from Excel to Outlook Calendar - excel

Question

I am trying to import dates in column "E" to my Outlook calendar.
I have code started, but it is only adding certain dates to my calendar and not adding what it seems to me like multiple dates for ex. The date of 6/2 is being added to my calendar with correct subject date and body, but for dates for 6/1 I have an empty slot.
Option Explicit
Public Sub CreateOutlookApptz()
Sheets("Sheet2").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) = ""
Set subFolder = CalFolder
Set olAppt = subFolder.Items.Add(olAppointmentItem)
MsgBox Cells(i, 6) + Cells(i, 7)
'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

Answer 1

Try it this way.
Private Sub Add_Appointments_To_Outlook_Calendar()
'Include Microsoft Outlook nn.nn Object Library from Tools -> References
Dim oAppt As AppointmentItem
Dim Remind_Time As Double
i = 2
Subj = ThisWorkbook.Sheets(1).Cells(i, 1)
'Loop through entire list of Reminders to be added
While Subj <> ""
Set oAppt = Outlook.Application.CreateItem(olAppointmentItem)
oAppt.Subject = Subj
oAppt.Location = ThisWorkbook.Sheets(1).Cells(i, 2)
oAppt.Start = ThisWorkbook.Sheets(1).Cells(i, 3)
Remind_Time = ThisWorkbook.Sheets(1).Cells(i, 4) * 1 * 60
oAppt.ReminderMinutesBeforeStart = Remind_Time
oAppt.AllDayEvent = True
oAppt.Save
i = i + 1
Subj = ThisWorkbook.Sheets(1).Cells(i, 1)
Wend
MsgBox "Reminder(s) Added To Outlook Calendar"
End Sub
Your setup will look something like this.
I talk about this concept, and many other similar, but different, things in my book.
https://www.amazon.com/Automating-Business-Processes-Reducing-Increasing-ebook/dp/B01DJJKVZC?ie=UTF8&keywords=ryan%20shuell&qid=1464361126&ref_=sr_1_1&sr=8-1