Outlook appointments using Excel

[t0m_c]

I have a excel sheet wich include dates with an according appointment. The script makes appointments according to the name of the corresponding cell
Example:
A22 = 21/01/2022
B22 = GT
It will make an appointment called "GT" on that date
But it won't make an appointment if there is "0", "Za" or "Zo" (wich is good!).

The current scenario
Now i currently have 2 macro's

• 1 to delete all appointments with the names in column B

• 1 to add appointments with the names in column B

Why? Because when an appointment name has changed, it needs to delete the old appointment and make a new one, with the new name.
The ideal scenario is to lookup if there is an appointment in that day matching the corresponding cell, and if there isn't, VBA will delete the appointment (if it matches with a certain criteria) and make a new one with the name in the cell. (Why the criteria? Because it can't delete every appointment in that day. So if the appointment is called "GT" or "A" or, something from the criteria ... it can delete it. If there is an apointment in that day that matched with the cell, it does nothing)

All in one script, 2 scripts to run separately is not convinient
The Problem
Now it will delete every appointment, and make every appointment again, even if the appointment is allready correct.
can someone help me with this?


Example of what the script needs to be doing

Reward? Eternal praise from me :D

Code add appointment

Sub Add_Appointments()
    'Include Microsoft Outlook nn.nn Object Library from Tools -> References
    Dim oApp     As Outlook.Application
    Dim oAppt    As Outlook.AppointmentItem
    Dim oNS      As Outlook.Namespace
    Dim oFolder  As Outlook.MAPIFolder
    Dim sSubj    As String
    Dim lCount   As Long
    Dim oRge     As Range
    Dim oCell    As Range
    Dim DeleteCount  As Long
                                                  
    
       
    lCount = 0
    Set oApp = Outlook.Application
    Set oNS = oApp.GetNamespace("MAPI")
    Set oFolder = oNS.GetDefaultFolder(olFolderCalendar)

    Set oRge = ThisWorkbook.Sheets(1).Cells(1, 1).CurrentRegion ' Grab whole range
    Set oRge = oRge.Resize(oRge.Rows.Count - 1, 1).Offset(1)    ' Skip first row and keep only first column to run through.
    For Each oCell In oRge
        sSubj = oCell.Offset(0, 1).Value
        If sSubj <> "" And sSubj <> "0" And sSubj <> "Za" And sSubj <> "Zo" Then
            Set oAppt = oFindAppointment(oFolder, sSubj, oCell.Value, , True)
            If oAppt Is Nothing Then
                ' Appointment did not already exist
                Set oAppt = Outlook.Application.CreateItem(olAppointmentItem)
                oAppt.BusyStatus = 3
                oAppt.Subject = sSubj
                oAppt.Start = oCell.Value
                oAppt.ReminderMinutesBeforeStart = 60
                oAppt.AllDayEvent = True
                oAppt.Save
                lCount = lCount + 1
            End If
         End If
        
    Next
    MsgBox CStr(lCount) & " Reminder(s) Added To Outlook Calendar"

    
End Sub

Function oFindAppointment(oFolder As Outlook.MAPIFolder, sSubj As String, dStarDateTime As Date, Optional sBodyText As String = "", Optional bAllDayEvent As Boolean = False) As Outlook.AppointmentItem
  
    Dim oCalItems As Outlook.Items
    Dim oCalItem  As Object
    Dim sFilter   As String

    Set oFindAppointment = Nothing
    ' Get calendar items with the specified subject and start time
    sFilter = "[Subject] = '" & sSubj & "' and [Start] = '" & Format(dStarDateTime, "ddddd Hh:Nn") & "'"
    Set oCalItems = oFolder.Items.Restrict(sFilter)

    ' See if any calendar items match the specified body text and/or AllDayEvent requirement
    For Each oCalItem In oCalItems
        If sBodyText = "" Then
            Set oFindAppointment = oCalItem
        ElseIf InStr(1, oCalItem.Body, sBodyText, vbTextCompare) > 0 Then
            Set oFindAppointment = oCalItem
        End If
        If Not oFindAppointment Is Nothing Then
            If bAllDayEvent = oFindAppointment.AllDayEvent Then
                Exit For
            End If
            Set oFindAppointment = Nothing 'No match, keep looking
        End If
    Next
End Function

Code Delete Appointment

Sub Delete_Appointments()

 Dim oApp                 As Outlook.Application
 Dim oNameSpace           As Outlook.Namespace
 Dim oApptItem            As Outlook.AppointmentItem
 Dim oFolder              As Outlook.MAPIFolder
 Dim oMeetingoApptItem    As Outlook.MeetingItem
 Dim oObject              As Object
 Dim iUserReply           As VbMsgBoxResult
 Dim sErrorMessage        As String
 Dim j                    As Integer
 Dim i                    As Integer
 

 Set oApp = Outlook.Application
 Set oNameSpace = oApp.GetNamespace("MAPI")
 Set oFolder = oNameSpace.GetDefaultFolder(olFolderCalendar)
 
On Error Resume Next
 For Each oObject In oFolder.Items
   If oObject.Class = olAppointment Then
     Set oApptItem = oObject
     For j = 2 To Range("B1").End(xlDown).Row
     If InStr(oApptItem.Subject, Range("B" & j).Value) > 0 Then
     
            oApptItem.Delete
            
     End If
     Next j
     
   End If
 Next oObject


For i = 2 To Range("B1").End(xlDown).Row
    strFind = "[Subject] ='" & Range("B" & i).Value & "'"
    
    Set oApptItem = oFolder.Items.Find(strFind)
    
    If Not TypeName(oApptItem) = "Nothing" Then
        oApptItem.Delete
    End If
    
    
Next i



 
 Set oApp = Nothing
 Set oNameSpace = Nothing
 Set oApptItem = Nothing
 Set oFolder = Nothing
 Set oObject = Nothing
 
 Exit Sub

End Sub