Outlook reminder from Excel code problems

Question

I have the following code running to create reminders in Outlook.

' requires a reference to the Microsoft Outlook          x.0 Object Library
Sub RegisterAppointmentList()
' adds a list of appontments to the Calendar in          Outlook
Dim olApp As Outlook.Application
Dim olAppItem As Outlook.AppointmentItem
Dim r As Long
DeleteTestAppointments ' deletes previous test appointments
On Error Resume Next
Set olApp = GetObject("", "Outlook.Application")
On Error GoTo 0
If olApp Is Nothing Then
On Error Resume Next
Set olApp =   CreateObject("Outlook.Application")
On Error GoTo 0
If olApp Is Nothing Then
    MsgBox "Outlook is not available!"
    Exit Sub
End If
End If
r = 5 ' first row with appointment data in the active worksheet
While Len(Cells(r, 5).Formula) > 0
Set olAppItem =     olApp.CreateItem(olAppointmentItem) ' creates a    new appointment
With olAppItem
    ' set default appointment values
    On Error Resume Next
    .Start = Cells(r, 9).Value
    .End = Cells(r, 9)
    .Subject = Cells(r, 2).Value + Cells(r,        3).Value
    .Location = Cells(r, 5).Value
    .Body = Cells(r, 9).Value
    .ReminderSet = True
    .ReminderMinutesBeforeStart = 20160
    .Categories = "TestAppointment" ' add    this to be able to delete the testappointments
    On Error GoTo 0
    .Save ' saves the new appointment to the default folder
End With
r = r + 1
Wend
Set olAppItem = Nothing
Set olApp = Nothing
End Sub

Sub DeleteTestAppointments()
' deletes all testappointments in Outlook
Dim olApp As Outlook.Application
Dim OLF As Outlook.MAPIFolder
Dim r As Long, dCount As Long
On Error Resume Next
Set olApp = GetObject("",     "Outlook.Application")
On Error GoTo 0
If olApp Is Nothing Then
On Error Resume Next
Set olApp = GetObject("Outlook.Application")
On Error GoTo 0
If olApp Is Nothing Then
    MsgBox "Outlook is not available!"
    Exit Sub
End If
End If
Set OLF =    olApp.GetNamespace("MAPI").GetDefaultFolder(olFolderCalendar)
dCount = 0
For r = OLF.Items.Count To 1 Step -1
If TypeName(OLF.Items(r)) = "AppointmentItem" Then
    If InStr(1, OLF.Items(r).Categories, "TestAppointment", vbTextCompare) = 1 Then
        OLF.Items(r).Delete
        dCount = dCount + 1
    End If
End If
Next r
Set olApp = Nothing
Set OLF = Nothing
End Sub

However I have a couple of anomalies with it;

1. It does not always set the "subject" to what is written in columns 2 and 3 of the relevant row. It just returns a blank on the reminder.
2. I would like it to not create a reminder if column L says "quarantined" or "inspection". Any help would be grateful.

Here is link to excel workbook http://db.tt/Goqni3uf

Answer 1

Glad you got it working :)

For the next request embed your code between this condition

While Len(Cells(r, 5).Formula) > 0
    Select Case LCase(Cells(r, 12).Value)
        Case "quarantined", "inspected"
        Case Else
            '
            '~~> Your code to create an appointment
            '
    End Select
Wend