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, ... 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
Now it will delete every appointment, and make every appointment again, even if the appointment is allready correct.
can someone help me with this?
Code add appointment
Code: Select all
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