Create non-duplicate appointments from list in worksheet - excel

Question

I am trying to make appointments from a given date.
To avoid duplicates I tried coloring the cells but that does not seem viable.
Now I am trying to check if an appointment with the same "subject" as the cell exists and if so go to the next line.
I get the error
Object required
Private Sub Workbook_Open()
Set myOutlook = CreateObject("Outlook.Application")
r = 2
Do Until Trim(Cells(r, 8).Value) = ""
If Cells(r, 9).Value = myapt.Subject = Cells(r, 9).Value Then
r = r + 1
Else
Set myapt = myOutlook.createitem(1)
myapt.Subject = Cells(r, 9).Value
myapt.Start = Cells(r, 8).Value
myapt.AllDayEvent = True
myapt.BusyStatus = 5
myapt.ReminderSet = True
'myapt.Body = ""
myapt.Save
Cells(r, 8).Interior.ColorIndex = 4
r = r + 1
End If
Loop
End Sub

Answer 1

To check if an item exists you need to filter the existing items:
Option Explicit
Public Sub CreateItemsIfNotExist()
Dim ws As Worksheet
Set ws = ThisWorkbook.Worksheets("Sheet1") 'define your sheet!
Dim olApp As Object 'create outlook application
Set olApp = CreateObject("Outlook.Application")
Dim olNS As Object 'get namespace
Set olNS = olApp.GetNamespace("MAPI")
'define constants if using late binding
Const olFolderCalendar As Long = 9
Const olAppointmentItem As Long = 1
Dim olRecItems As Object 'get all appointments
Set olRecItems = olNS.GetDefaultFolder(olFolderCalendar)
Dim strFilter As String 'filter for appointments
Dim olFilterRecItems As Object 'filtered appointments
Dim iRow As Long
iRow = 2
Do Until Trim$(ws.Cells(iRow, 8).Value) = vbNullString
'filter appointments for subject
strFilter = "[Subject] = '" & Trim$(ws.Cells(iRow, 9).Value) & "'"
Set olFilterRecItems = olRecItems.Items.Restrict(strFilter)
If olFilterRecItems.Count = 0 Then 'if subject does not exist
With olApp.CreateItem(olAppointmentItem)
.Subject = ws.Cells(iRow, 9).Value
.Start = ws.Cells(iRow, 8).Value
.AllDayEvent = True
.BusyStatus = 5
.ReminderSet = True
.Save
End With
ws.Cells(iRow, 8).Interior.ColorIndex = 4
End If
iRow = iRow + 1
Loop
End Sub
Note that maybe you want to quit outlook in the end olApp.Quit.