Import dates from Excel to Outlook Calendar

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

ASH · Accepted Answer

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

Import dates from Excel to Outlook Calendar

Answers (1)

Related Questions