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.

Hi, the column where I would like to check if there is a date is column 12, if there is a date (must be an actual date, not a header etc.) in that cell then the reminder would be created for that date. — Mr_Col, Apr 03 '19 at 11:53
Simply put your code between `If IsDate(.Cells(i, 12).Value) Then` and `End If` — Siddharth Rout, Apr 03 '19 at 11:56
At the moment I have the macro inserting "added" into column 13, i then uses this to determine if the reminder has already been set, and stops duplication. How would I also incorporate that? Thanks so much in advance — Mr_Col, Apr 03 '19 at 13:28
`If IsDate(.Cells(i, 12).Value) And Ucase(Trim(.Cells(i, 13).Value)) <> "ADDED" Then` — Siddharth Rout, Apr 03 '19 at 13:34
Hi Siddarth, thanks for the assistance, but that doesn't seem to work. It causes issues with the rest of the code... such as the 'Loop' and 'DoUntil' etc. Perhaps I need to completely re-write the code? — Mr_Col, Apr 03 '19 at 14:00
Yes. **1.** Find the last row in Column 12. See [This](https://stackoverflow.com/questions/11169445/error-in-finding-last-used-cell-in-vba/11169920#11169920) **2.** Use a For Loop to loop though Col 12 and use the `IF` condition that I gave above. — Siddharth Rout, Apr 03 '19 at 14:07

reFractil · Accepted Answer · 2019-04-08T13:04:35.870

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

Hi reFractil, thanks for the help. Is there anyway I could have it not run Do Until Trim(Cells(i, 1).Value) = "", and just look in column 12 and 13 - if there is a date in there, and no "added" in column 13 then it runs the macro? At the moment I have to have 'dummy' text in column 1 to make the macro work. Thanks in advance! — Mr_Col, Apr 08 '19 at 08:03
@Mr_Col, I have edited my answer, hope it helps if not let me know and I'll look into other options. ;) — reFractil, Apr 08 '19 at 13:06
that works an absolute treat - thank you so much for your help!! — Mr_Col, Apr 09 '19 at 09:44

Creating reminders in Outlook from an Excel sheet ignoring blank cells

1 Answers1