VBA Check existing Calendar appointments when importing from excel.

[Yosepht]

Hey guys,

I've already posted something similar but i replied to my own post and im concerned no one will see it, so here is the problem:

I'm stuck trying to prevent duplicate appointments being created when i run the following code to import excel dates to outlook.
I need the code to ignore rows where the subject, start and body entries are an exact match to an existing appointment in my calendar.

Public Sub CreateOutlookAppointments()
   Sheets("sheet1").Select
    On Error GoTo Err_Execute
    
    Dim olApp As Outlook.Application
    Dim olAppt As Outlook.AppointmentItem
    Dim blnCreated As Boolean
    Dim olNs As Outlook.Namespace
    Dim CalFolder As Outlook.MAPIFolder
    
    Dim i As Long
    
    On Error Resume Next
    Set olApp = Outlook.Application
    
    If olApp Is Nothing Then
        Set olApp = Outlook.Application
         blnCreated = True
        Err.Clear
    Else
        blnCreated = False
    End If
    
    On Error GoTo 0
    
    Set olNs = olApp.GetNamespace("MAPI")
    Set CalFolder = olNs.GetDefaultFolder(olFolderCalendar)
        
    i = 2
    Do Until Trim(Cells(i, 1).Value) = ""
        ' get the start date
        Dim startDate As Date
        startDate = Cells(i, 3).Value
        ' get the recipients
        Dim theRecipients As String
        theRecipients = Cells(i, 7).Value
        ' check whether the start date is today or later, and whether recipients exist
        If startDate >= Date And Len(theRecipients) = 0 Then
            Set olAppt = CalFolder.Items.Add(olAppointmentItem)
            With olAppt
            'Define calendar item properties
                .Subject = Cells(i, 1) + Cells(i, 2)
                .Start = Cells(i, 4)
                .Categories = Cells(i, 5)
                .Body = Cells(i, 6)
                .AllDayEvent = True
                .BusyStatus = olFree
                .ReminderMinutesBeforeStart = 2880
                .ReminderSet = True
                .Display
            End With
        End If
        i = i + 1
    Loop
    Set olAppt = Nothing
    Set olApp = Nothing
    
    Exit Sub
    
Err_Execute:
    MsgBox "An error occurred - Exporting items to Calendar."
    
End Sub

Here is a sample of my workbook that the code currently creates appointments from.

 

[John_w]

Put this function in the module:

Private Function Find_Appointment(calendarFolder As Outlook.MAPIFolder, subject As String, startDateTime As Date, bodyText As String) As Outlook.AppointmentItem

    Dim filter As String
    Dim i As Long
    Dim olCalendarItems As Outlook.Items
   
    Set Find_Appointment = Nothing
   
    'Get calendar items with the specified subject and start time
       
    filter = "[Subject] = '" & subject & "' and [Start] = '" & Format(startDateTime, "ddddd Hh:Nn") & "'"
    Set olCalendarItems = calendarFolder.Items.Restrict(filter)
   
    'See if any calendar items match the specified body text
   
    If Not olCalendarItems Is Nothing Then
        i = 0
        While i < olCalendarItems.Count And Find_Appointment Is Nothing
            i = i + 1
            If StrComp(olCalendarItems(i).Body, bodyText & " " & vbCrLf, vbTextCompare) = 0 Then Set Find_Appointment = olCalendarItems(i)
        Wend
    End If
   
End Function

and call it from your macro like this:

        If startDate >= Date And Len(theRecipients) = 0 Then
            Set olAppt = Find_Appointment(CalFolder, Cells(i, 1) & Cells(i, 2), Cells(i, 4), Cells(i, 6))
            If olAppt Is Nothing Then
                Set olAppt = CalFolder.Items.Add(olAppointmentItem)
                With olAppt
                'Define calendar item properties
                    .subject = Cells(i, 1) + Cells(i, 2)
                    .Start = Cells(i, 4)
                    .Categories = Cells(i, 5)
                    .Body = Cells(i, 6)
                    .AllDayEvent = True
                    .BusyStatus = olFree
                    .ReminderMinutesBeforeStart = 2880
                    .ReminderSet = True
                    .Display
                End With
            End If
        End If

Note - you may need to adjust the code which looks for the matching body text - StrComp(olCalendarItems(i).Body, bodyText & " " & vbCrLf, vbTextCompare). I found that Outlook appends a space and CR LF bytes to the calendar item's body text, hence the bodyText & " " & vbCrLf in that code to make the comparison equivalent.

 

[Yosepht]

Hey John,

Thanks, That solution worked perfectly! I tried adding the same code to another sub from the same module. This sub creates appointments with attendees as it should, but still creates duplicates. Could you take a look please? Here is the code with the modified lines you've suggested above:

Public Sub CreateOutlookMeetings()
   Sheets("sheet1").Select
    On Error GoTo Err_Execute
    
    Dim olApp As Outlook.Application
    Dim olAppt As Outlook.AppointmentItem
    Dim blnCreated As Boolean
    Dim olNs As Outlook.Namespace
    Dim CalFolder As Outlook.MAPIFolder
    
    Dim i As Long
    
    On Error Resume Next
    Set olApp = Outlook.Application
    
    If olApp Is Nothing Then
        Set olApp = Outlook.Application
         blnCreated = True
        Err.Clear
    Else
        blnCreated = False
    End If
    
    On Error GoTo 0
    
    Set olNs = olApp.GetNamespace("MAPI")
    Set CalFolder = olNs.GetDefaultFolder(olFolderCalendar)
        
    i = 2
    Do Until Trim(Cells(i, 1).Value) = ""
        ' get the start date
        Dim startDate As Date
        startDate = Cells(i, 3).Value
        ' get the recipients
        Dim theRecipients As String
        theRecipients = Cells(i, 7).Value
        ' check whether the start date is today or later, and whether recipients exist
        If startDate >= Date And Len(theRecipients) > 0 Then
        Set olAppt = Find_Appointment(CalFolder, Cells(i, 1) & Cells(i, 2), Cells(i, 4), Cells(i, 6))
            If olAppt Is Nothing Then
            Set olAppt = CalFolder.Items.Add(olAppointmentItem)
            With olAppt
               .MeetingStatus = olMeeting
                'Define calendar item properties
                    .subject = Cells(i, 1) + Cells(i, 2)
                    .Start = Cells(i, 4)
                    .Categories = Cells(i, 5)
                    .Body = Cells(i, 6)
                    .AllDayEvent = True
                    .BusyStatus = olFree
                    .ReminderMinutesBeforeStart = 2880
                    .ReminderSet = True
                ' get the recipients
                Dim RequiredAttendee As Outlook.Recipient
                Set RequiredAttendee = .Recipients.Add(theRecipients)
                    RequiredAttendee.Type = olRequired
                    .Display
                End With
            End If
        End If
        i = i + 1
    Loop
    Set olAppt = Nothing
    Set olApp = Nothing
    
    Exit Sub
    
Err_Execute:
    MsgBox "An error occurred - Exporting items to Calendar."
    
End Sub

 

[John_w]

A possible bug in your second macro, which also applies to your first:

.subject = Cells(i, 1) + Cells(i, 2)

maybe should be:
.subject = Cells(i, 1) & Cells(i, 2)

The + adds the cell values, whereas & concatenates them, so if there is a number in both cells the subject will be the sum of the cells rather than a string of the cells.
Apart from that I don't see anything wrong with your second macro - it looks similar to your first - and you are calling Find_Appointment correctly, as long as the data is in the same columns as your first post. Try debugging the code with the F8 key.

 

[Yosepht]

Thanks for your response, John.
I tried the & replacement but this didn't have any effect. Could it be a problem caused by the fact theses appointments are meetings and are stored or saved differently to the standard appointments?

 

[John_w]

I haven't looked at whether appointments and meetings are stored differently.

What are the times for the dates in column D?

If they are not 00:00 then either delete the .AllDayEvent = True line (the default is False) so that the meeting will be created on the specified date and time (and Find_Appointment looks at that date-time), or change the call to:

Set olAppt = Find_Appointment(CalFolder, Cells(i, 1).Value & Cells(i, 2).Value, Int(Cells(i, 4).Value), Cells(i, 6).Value)

The Int function removes the time part of the date, so that Find_Appointment looks at the specified date and a time of 00:00. The time part of an all day event start time is 00:00.

 

[Yosepht]

*Internet disconnected*

 

[Yosepht]

Hey John, Thanks for all your help so far!

The values in column D don't contain any times, only the date. Id like to keep the appointments as all-day events, so i tried:
Set olAppt = Find_Appointment(CalFolder, Cells(i, 1).Value & Cells(i, 2).Value, Int(Cells(i, 4).Value), Cells(i, 6).Value) but to no avail.

Could it be linked to the formulas I have in the body cells?

An example cell formula in Column F that has a Recipient email address in Column G is:
(=CONCATENATE("Just a reminder that your daily reviews are due for renewal on ", TEXT([@[Renewal Date]], "dd/mm/yyyy")) Which outputs:
Just a reminder that your daily reviews are due for renewal on 00/01/1900

Whereas the cells without email addresses look like this: (=CONCATENATE("Renewal ",TEXT(C25,"dd/mm/yyyy")) which outputs:
Renewal 00/01/1900

I can't wrap my head around why it works for normal appointments, but not for appointments with attendees. Both contain olAppt.AllDayEvent = True.

Failing this, the only differences between the two are the following lines
olAppt.MeetingStatus = olMeeting Dim RequiredAttendee As Outlook.Recipient Set RequiredAttendee = .Recipients.Add(theRecipients) RequiredAttendee.Type = olRequired .Display End With

Could this be the issue?

 

[Yosepht]

I Debugged with F8 and i think the appointments are not being discovered by Private Function Find_Appointment. I am no expert though so i am most likely wrong.

 

[John_w]

Are you actually saving or sending the meetings? .Display just displays the meeting and unless you save or send it the meeting isn't created.

I tried my test data with your formulas in column F and the code still works me. I'm using .Save instead of .Display so that the meeting is created and saved.

Yes, it's odd that the code works for normal appointments, which suggests the filter used to find matching appointments is correct:

    filter = "[Subject] = '" & subject & "' and [Start] = '" & Format(startDateTime, "ddddd Hh:Nn") & "'"

The ddddd is the day, month and year formatted according to your system's short date format. The Hh:Nn is the hour and minute with leading zeroes, which should give 00:00 if there are no times in column D. You could try changing this part of the format string to 00:00.

If it still doesn't work, could you upload an anonymised/dummy data workbook to a file sharing site and I'll have a look.