Check for existng appointments in calendar to prevent duplicate entries when importing from excel

[Yosepht]

Hey Guys,

I'm stuck trying to prevent duplicate appointments being created when i run the following code to import excel dates to outlook.

Public Sub CreateOutlookMeetings()
   Sheets("sheet1").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 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) = ""
        ' get the start date
        Dim startDate As Date
        startDate = Cells(i, 3).Value
        ' get the recipients
        Dim theRecipients As String
        theRecipients = Cells(i, 7).Value
        ' check whether the start date is today or later, and whether recipients exist
        If startDate >= Date And Len(theRecipients) > 0 Then
            Set olAppt = CalFolder.Items.Add(olAppointmentItem)
            With olAppt
               .MeetingStatus = olMeeting
            'Define calendar item properties
                .Subject = Cells(i, 1) + Cells(i, 2)
                .Start = Cells(i, 4)
                .Categories = Cells(i, 5)
                .Body = Cells(i, 6)
                .AllDayEvent = True
                .BusyStatus = olFree
                .ReminderMinutesBeforeStart = 2880
                .ReminderSet = True
            ' get the recipients
                Dim RequiredAttendee As Outlook.Recipient
                Set RequiredAttendee = .Recipients.Add(theRecipients)
                    RequiredAttendee.Type = olRequired
                .Display
            End With
        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 need the code to ignore subject, start and body entries that match existing appointments in my calendar.

Here is a sample of my workbook that the code currently creates appointments from.

 

[Yosepht]

Here is an up to date example of the workbook