'Outlook calendar events using vba and excel

I have this Excel sheet which contains dates with a appointment as shown in this example:

See text below or screenshot:

28/06/2022  0
29/06/2022  0
30/06/2022  AD
1/07/2022   4,5UA
2/07/2022   Za
3/07/2022   Zo
4/07/2022   V
5/07/2022   V

The current code has been written by someone, and it helped me a lot current code.

When there is an appointment in column 2 it will make an appointment in outlook with the according date in column 1.

When there is "0", "Za" or "Zo" it skips it.

When there is already an appointment with the same name on that day, it won't make another one.

This works great!

There are only two flaws that I can't get to program out.

  1. When there is a "0" in column 2 and an appointment for that day called "V" it won't delete that appointment.
  2. When there is a "V" (or something else) in column 2 and an appointment for that day called "AD" (or something other than what is in de excel sheet) it won't delete that appointment.

My code:

Sub Add_Appointments_To_Outlook_Calendar()
    '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

I've tried to include this

But it won't work, if someone could help me that would really mean a lot to me.

I'm not experienced in VBA but I'm trying my very best to make it work



Sources

This article follows the attribution requirements of Stack Overflow and is licensed under CC BY-SA 3.0.

Source: Stack Overflow

Solution Source