Investigate Outlook Calendar for Meetings from Excel

[JamesL]

Hi,

I have a macro that sets up reminder in the Outlook calendar if someone need to go on a course (code is below). It does this by reading a pivot table of the dates, courses and names. Then creates a reminder, adds the relevant data and saves it to the calendar. This works fine.

The problem is the XL sheet that holds the training dates and training course will change. Thereore when there is a change to the training dates i would like to search for all the reminders already saved in the calendar , delete them, then run the code below again to add the new reminders.

Is possible therefore to look through the Outlook calendar and remove the old meetings? The common part about the reminders is that they have the same subject ("Training Reminder - Please Open") and are all day events.


Thanks in advance,
James


Sub SetUpApponintmentsForTraining()

Dim myOlApp
Dim myItem
Dim ColumnPivot As Integer
Dim PivotRow As Integer
Dim EndColumn As Integer
Dim BodyMsg As String
Dim EndRow As Integer
Dim ARow As Integer
Dim BRow As Integer
Dim ADate As Date
Dim SetDate As Date
Dim SearchForNumbers As Integer
Dim SearchForCourse As Integer
Dim CourseName As String
Dim StaffName As String

'open Outlook
Set myOlApp = CreateObject("Outlook.Application")

' myOlApp.visible = True

Sheet3.Visible = True
Sheet3.Select

'Set the start position of the table
EndColumn = 2
EndRow = 5

'FIND LAST COLUMN ON PIVOT
Do Until Sheet3.Cells(4, EndColumn) = "Grand Total"
EndColumn = EndColumn + 1
Loop

EndColumn = EndColumn - 1 ' to miss Grand total

'FIND LAST ROW
Do Until Sheet3.Cells(EndRow, 1) = "Grand Total"
EndRow = EndRow + 1
Loop

EndRow = EndRow - 1 ' to miss Grand total

'LOOK FOR SAME DATES

'GO THROUGH PIVOT TABLE
For PivotRow = 5 To EndRow

Set myItem = myOlApp.CreateItem(olAppointmentItem) 'open a new item each time

BodyMsg = "Ensure that these staff are going on these courses:" & vbNewLine

'GET ACTIVE NXT DATE
Do Until Sheet3.Cells(PivotRow, 1) <> ""
PivotRow = PivotRow + 1
Loop

On Error Resume Next
ADate = Sheet3.Cells(PivotRow, 1)
If ADate = 0 Or ADate < Now Then GoTo SkipThis
On Error GoTo 0

ARow = PivotRow

'GET ACTIVE 'TOTAL' ROW
Do Until Right(Sheet3.Cells(PivotRow, 1), 5) = "Total"
PivotRow = PivotRow + 1
Loop

BRow = PivotRow


'FIND A No & TRAINING COURSE
For SearchForNumbers = 3 To EndColumn
If Sheet3.Cells(BRow, SearchForNumbers) = 1 Then
For SearchForCourse = ARow To BRow - 1
If Sheet3.Cells(SearchForCourse, SearchForNumbers) = 1 Then
CourseName = Sheet3.Cells(SearchForCourse, 2)
StaffName = Sheet3.Cells(4, SearchForNumbers)
BodyMsg = BodyMsg + StaffName & ": " & CourseName & vbNewLine
End If
Next SearchForCourse
End If
Next SearchForNumbers


'OPEN APPOINTMENT
myItem.Display

'myItem.MeetingStatus = olMeeting
myItem.Subject = "Training Reminder - Please Open"

'SetDate intially
SetDate = ADate - 7
'If ADate is Sat or Sun goto next Mon
If Left(Format(ADate, "ddd"), 3) = "Sat" Then SetDate = ADate - 5
If Left(Format(ADate, "ddd"), 3) = "Sun" Then SetDate = ADate - 6

myItem.Start = SetDate

myItem.AllDayEvent = True

BodyMsg = BodyMsg + vbNewLine

myItem.Body = BodyMsg

' myItem.Close olSave

Set myItem = Nothing


SkipThis:

Next PivotRow


Sheet3.Visible = xlSheetVeryHidden


End Sub