Creating reminders in Outlook from an Excel sheet ignoring blank cells

Question

I am looking to set reminders in my Outlook calendar, based on a date in a cell in Excel.

I have this running. When you save the workbook it auto populates the reminders in Outlook.

I want to ignore blanks in the column where I have the dates.

Option Explicit

Public Sub CreateOutlookApptz()
    Sheets("Invoicing Schedule").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 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 = 1
    Do Until Trim(Cells(i, 1).Value) = ""
        arrCal = Cells(i, 1).Value
        If Trim(Cells(i, 13).Value) = "" Then
            Set olAppt = CalFolder.Items.Add(olAppointmentItem)

            'MsgBox subFolder, vbOKCancel, "Folder Name"

            With olAppt

                'Define calendar item properties
                .Start = Cells(i, 12) + TimeValue("9:00:00")
                .End = Cells(i, 12) + TimeValue("10:00:00")

                .Subject = "Invoice Reminder"
                .Location = "Office"
                .Body = Cells(i, 4)
                .BusyStatus = olFree
                .ReminderMinutesBeforeStart = 7200
                .ReminderSet = True
                .Categories = "Finance"
                .Save

            End With
        Cells(i, 13) = "Added"

        End If

        i = i + 1
    Loop

    Set olAppt = Nothing
    Set olApp = Nothing

    Exit Sub

Err_Execute:
    MsgBox "An error occurred - Exporting items to Calendar."

End Sub

I want to look in a column, if that column contains a date, then set the reminder based on another cell value.

Answer 1

Like Siddharth suggested, and If stament in the right place should do the trick...

Give it a try to this...

Option Explicit
Public Sub CreateOutlookApptz()

   Sheets("Invoicing Schedule").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 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 = 1
Do Until Trim(Cells(i, 1).Value) = ""

'IF Validation for Col 12 and 13    
If IsDate(Cells(i, 12)) And Ucase(Trim(Cells(i, 13))) <> "ADDED" Then

    arrCal = Cells(i, 1)

    Set olAppt = CalFolder.Items.Add(olAppointmentItem)

    'MsgBox subFolder, vbOKCancel, "Folder Name"

    With olAppt

    'Define calendar item properties
        .Start = Cells(i, 12) + TimeValue("9:00:00")
        .End = Cells(i, 12) + TimeValue("10:00:00")


        .Subject = "Invoice Reminder"
        .Location = "Office"
        .Body = Cells(i, 4)
        .BusyStatus = olFree
        .ReminderMinutesBeforeStart = 7200
        .ReminderSet = True
        .Categories = "Finance"
        .Save

    End With
    Cells(i, 13) = "Added"


End If

        i = i + 1
Loop
    Set olAppt = Nothing
    Set olApp = Nothing

    Exit Sub

Err_Execute:
    MsgBox "An error occurred - Exporting items to Calendar."

End Sub

EDIT: Based on your comments, you could determine the total cells used in Column 12, like this LastRow = Cells(Rows.Count, 12).End(xlUp).Row and then loop through it using a For Next loop.

Replace your Do Until block with this.

Dim LastRow As Long
LastRow = Cells(Rows.Count, 12).End(xlUp).Row

For i = 2 To LastRow

If IsDate(Cells(i, 12)) And UCase(Trim(Cells(i, 13))) <> "ADDED" Then

    arrCal = Cells(i, 1)

    Set olAppt = CalFolder.Items.Add(olAppointmentItem)

    'MsgBox subFolder, vbOKCancel, "Folder Name"

    With olAppt

    'Define calendar item properties
        .Start = Cells(i, 12) + TimeValue("9:00:00")
        .End = Cells(i, 12) + TimeValue("10:00:00")


        .Subject = "Invoice Reminder"
        .Location = "Office"
        .Body = Cells(i, 4)
        .BusyStatus = olFree
        .ReminderMinutesBeforeStart = 7200
        .ReminderSet = True
        .Categories = "Finance"
        .Save

    End With
    Cells(i, 13) = "Added"


End If

Next