VBA to delete Outlook Appointments

[swayp11]

I am trying to write code that is going to add events to a calendar based on an excel sheet, but first it needs to delete any appointments that have the same subject as anything in my list. Here is my code:

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
 
 
 On Error Resume Next
 ' check if Outlook is running
 Set oApp = GetObject("Outlook.Application")
 If Err <> 0 Then
'if not running, start it
   Set oApp = CreateObject("Outlook.Application")
 End If
 
 On Error GoTo Err_Handler


 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("A1").End(xlDown).Row
     If InStr(oApptItem.Subject, Range("A" & j).Value) > 0 Then
     
            oApptItem.Delete
            
     End If
     Next j
     
   End If
 Next oObject
On Error GoTo Err_Handler


For i = 2 To Range("A1").End(xlDown).Row


    Set oApptItem = oApp.CreateItem(olAppointmentItem)


    With oApptItem
        .Subject = Range("A" & i).Value
        .Start = Range("B" & i).Value
        .AllDayEvent = True
        .Save
        .Send
    End With
Next i






 
 Set oApp = Nothing
 Set oNameSpace = Nothing
 Set oApptItem = Nothing
 Set oFolder = Nothing
 Set oObject = Nothing
 
 Exit Sub
 
Err_Handler:
 MsgBox ("Error running script.  Did not run properly.")
 
End Sub

When I run it, it doesn't always delete everything. It seems to delete a couple and then stop working. If I take away the error trapping, there is an error trying to delete because 'the object has moved or doesn't delete'. It happens on this line:

If InStr(oApptItem.Subject, Range("A" & j).Value) > 0 Then

When I hover over oApptItem.Subject, it says this item has moved or been removed.

What is going on?

Thanks!

 

[Ragnar1211]

The problem occurs because you are looping through the same outlook item, even though you have said to delete it, thus causing an error.

Therefore you need to exit the "for j" loop if the if statement is true.

Add Exit For after the oApptItem.Delete line and let me know if that fixes it.

Gerry

 

[swayp11]

The problem occurs because you are looping through the same outlook item, even though you have said to delete it, thus causing an error.

Therefore you need to exit the "for j" loop if the if statement is true.

Add Exit For after the oApptItem.Delete line and let me know if that fixes it.

Gerry

Thank you -- so obvious and I forgot it would keep going through that j loop.

But, for some reason, it still isn't deleting all of them. I know the subjects are the same because I'm adding them with another macro and reading the subject from the same cells. There are 14 total, one on each day (all day events). I add them all with a macro, and then I want to build this piece to delete them all. It deletes the first 5, but then doesn't delete the next 5. Then it deletes the next 3, and then stops deleting again.

If I run a second time, it 'catches' different batch of them.

I don't get an error anymore though after your update.

P.S. I'm not sure if it would work, if it is easier, more efficient, etc., if I were to do it the other way. Loop through the cells and then try and find that appointment and delete it. But still not sure why this way doesn't work.

 

[Ragnar1211]

Try assigning the oApptItem.Subject to a variable before the j loop eg. crtsubject = oApptItem.Subject and then use the variable within the j loop.
I have found controlling outlook to be a bit flaky, and you are asking it to read the exact same value from outlook over and over again every time in the j loop.

I am not sure if that will solve the problem, but it might. I'll keep thinking on it

 

[swayp11]

Hey Gerry,

I tried assigning to the subject first but still the same spotty deleting.

     Set oApptItem = oObject
     strSubject = oApptItem.Subject
     
     For j = 2 To Range("A1").End(xlDown).Row
        If strSubject = Range("A" & j).Value Then
    


            oApptItem.Delete
            Exit For
     
            
        End If
     Next j

I did notice that it seems to always delete the same ones. I have 14 appointments that I added via macro. When trying to use the above code to delete them, it always deletes 1 through 5, then leaves 6 through 9, then deletes 10 through 12, then leaves 13 through 14. After 3 runs, it ends up deleting them all.

Sometimes I've found that when VBA talks to other applications, the code runs 'too fast'. I'm wondering if it is just skipping over items?

I tried another route, which is looping through the Excel sheet and searching for that appointment and deleting it:

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

This code works. But I'm still confused as to why the other method doesn't work.

 

[Masha92]

Hi Guys,

I know this is a bit old but worth trying.

I have the same issue, i have to run the macro a couple of times to delete all appointments matching criteria.

I tried to slow down the macro but it didnt help.

Any idea why this happened?

Thanks,
Masha

 

[John_w]

Loop backwards through the items by changing the For Each loop in the original code to:

Dim i As Long
For i = oFolder.Items.Count To 1 Step -1
    If oFolder.Items(i).Class = olAppointment Then
        Set oApptItem = oFolder.Items(i)
        For j = 2 To Range("A1").End(xlDown).Row
            If InStr(oApptItem.Subject, Range("A" & j).Value) > 0 Then
                oApptItem.Delete
            End If
        Next
    End If
Next