VBA to delete Outlook Appointments

swayp11

Board Regular
Joined
Apr 27, 2009
Messages
107
Office Version
  1. 365
Platform
  1. Windows
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:

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:
Code:
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!
 

Excel Facts

What is the fastest way to copy a formula?
If A2:A50000 contain data. Enter a formula in B2. Select B2. Double-click the Fill Handle and Excel will shoot the formula down to B50000.
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
 
Upvote 0
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.
 
Last edited:
Upvote 0
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
 
Upvote 0
Hey Gerry,

I tried assigning to the subject first but still the same spotty deleting.
Code:
     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:
Code:
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.
 
Upvote 0
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
 
Upvote 0
Loop backwards through the items by changing the For Each loop in the original code to:

Code:
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
 
Upvote 0

Forum statistics

Threads
1,213,546
Messages
6,114,251
Members
448,556
Latest member
peterhess2002

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top