Option Explicit
Public Sub CreateDeleteAppointments()
   ActiveSheet.Select
    On Error GoTo Err_Execute
    Dim olNs As Object 'Outlook.Namespace
    Dim olApp As Object 'Outlook.Application
    Dim olAppt As Object 'Outlook.AppointmentItem
    Dim blnCreated As Boolean
    Dim CalFolder As Object 'Outlook.MAPIFolder
     
   Dim CalItems As Object 'Outlook.Items
   Dim ResItems As Object 'Outlook.Items
   Dim sFilter, strSubject As String
   Dim itm As Object
   Dim dtStart, dtEnd As Date
   
   
    Dim i As Long
     
    On Error Resume Next

Set olApp = GetObject(, "Outlook.Application")
If Err.Number <> 0 Then
Set olApp = CreateObject("Outlook.Application")
  blnCreated = True
 Err.Clear
Else
blnCreated = False
End If
     
    On Error GoTo 0
     
    Set olNs = olApp.GetNamespace("MAPI")
    Set CalFolder = olNs.GetDefaultFolder(9)
    Set CalItems = CalFolder.Items
    CalItems.Sort "[Start]"
 
    i = 2
    Do Until Trim(Cells(i, 1).Value) = ""
  
If Cells(i, 7).Value = "Delete" Then

' create search string to find events to delete
    strSubject = Cells(i, 5)
    dtStart = Cells(i, 1) + Cells(i, 3)
    dtEnd = Cells(i, 2) + Cells(i, 4)
        
    'create the Restrict filter by day and recurrence"
sFilter = "[Start] = '" & dtStart & "' And [End] = '" & dtEnd & "' And [Subject] = """ & strSubject & """"
'Debug.Print sFilter

Set ResItems = CalItems.Restrict(sFilter)

'Debug.Print ResItems.Count

'Loop through the items in the collection.
For Each itm In ResItems
   itm.Delete
Next

Else

    Set olAppt = CalFolder.Items.Add(1)

    With olAppt

    'Define calendar item properties
        .Start = Cells(i, 1) + Cells(i, 3)
        .End = Cells(i, 2) + Cells(i, 4)
        .Subject = Cells(i, 5)
        '.Location = Cells(i, 2)
       ' .Body = Cells(i, 3)
If Cells(i, 7).Value = "x" Then
     .AllDayEvent = True
End If
        .BusyStatus = 1
       ' .ReminderMinutesBeforeStart = Cells(i, 9)
        '.ReminderSet = True
        .Categories = Cells(i, 9)
        .Save
' For meetings or Group Calendars
     ' .Send
    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