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.

 

[Yosepht]

once the code is stable, i'll set it to send. I was concerned that my customers would receive dozens of invitations while testing it. Display is just to help me see what the code is doing before i send/save it manually. unfortunately the format change didnt work either. ill upload a dummy sample of the workbook.

 

[Yosepht]

Here is the link to the sample workbook on G drive:

Renewal Dates sample.xlsm

 

[John_w]

The macros work correctly with your data.

I can only suggest trying different date-time formats in the filter string:

    filter = "[Subject] = '" & subject & "' and [Start] = '" & Format(startDateTime, "General Date") & "'"
    filter = "[Subject] = '" & subject & "' and [Start] = '" & Format(startDateTime, "ddddd 00:00 AMPM") & "'"
    filter = "[Subject] = '" & subject & "' and [Start] = '" & Format(startDateTime, "ddddd 00:00") & "'"
    filter = "[Subject] = '" & subject & "' and [Start] = '" & Format(startDateTime, "ddddd ttttt") & "'"
    filter = "[Subject] = '" & subject & "' and [Start] = '" & Format(startDateTime, "ddddd h:nn AMPM") & "'"
    filter = "[Subject] = '" & subject & "' and [Start] = '" & Format(startDateTime, "ddddd hh:nn AMPM") & "'"
    filter = "[Subject] = '" & subject & "' and [Start] = '" & Format(startDateTime, "ddddd hh:nn") & "'"
    filter = "[Subject] = '" & subject & "' and [Start] = '" & Format(startDateTime, "dd/mm/yyyy hh:nn") & "'"          'UK date format
    filter = "[Subject] = '" & subject & "' and [Start] = '" & Format(startDateTime, "dd/mm/yyyy h:nn AMPM") & "'"      'UK date format
    filter = "[Subject] = '" & subject & "' and [Start] = '" & Format(startDateTime, "mm/dd/yyyy hh:nn") & "'"          'US date format
    filter = "[Subject] = '" & subject & "' and [Start] = '" & Format(startDateTime, "mm/dd/yyyy h:nn AMPM") & "'"      'US date format

Try the General Date one first.

 

[John_w]

Instead of the trial and error approach of trying different date-time formats in my previous post, here is another macro you can try. It loops through 16 different date-time formats to see if the current calendar item matches any of the formats. You have to select or open one or more calendar items before running it.

Note that the previous code looked for a matching subject, start date-time and body text (the latter with StrComp, but only if any items matching the subject and start date-time are found) . The one below just looks at subject and start date-time. Therefore if any of the formats below finds a match and it is a format you've tried before it means the body text is not being matched in the previous macro.

Public Sub Test_DateTime_Formats()

    Dim outApp As Outlook.Application
    Dim calendarItem As Outlook.AppointmentItem
    Dim calendarFolder As Outlook.MAPIFolder
    Dim calendarItems As Outlook.Items
    Dim dateTimeFormats As Variant
    Dim subject As String, startDateTime As Date
    Dim filter As String
    Dim i As Long
    
    dateTimeFormats = Array("ddddd 00:00 AMPM", "ddddd 00:00", "ddddd ttttt", "ddddd h:nn AMPM", "ddddd hh:nn AMPM", "ddddd hh:nn", _
                            "dd/mm/yyyy hh:nn", "dd/mm/yyyy h:nn AMPM", "mm/dd/yyyy hh:nn", "mm/dd/yyyy h:nn AMPM", _
                            "General Date", "Long Date", "Short Date", _
                            "ddddd ttttt", "ddddd 00:00", "ddddd hh:nn")
                      
    On Error Resume Next
    Set outApp = Outlook.Application
    If outApp Is Nothing Then Set outApp = Outlook.Application
    On Error GoTo 0
    
    On Error Resume Next
    Set calendarItem = outApp.ActiveInspector.CurrentItem
    If calendarItem Is Nothing Then Set calendarItem = outApp.ActiveExplorer.Selection.Item(1)
    On Error GoTo 0
    
    If Not calendarItem Is Nothing Then
    
        Set calendarFolder = calendarItem.Parent
        
        subject = calendarItem.subject
        startDateTime = calendarItem.Start
        
        'Test each date-time format by filtering Calendar items which match the subject and start time of the current item
        
        For i = 0 To UBound(dateTimeFormats)
            
            filter = "[Subject] = '" & subject & "' and [Start] = '" & Format(startDateTime, dateTimeFormats(i)) & "'"
        
            Set calendarItems = calendarFolder.Items.Restrict(filter)
            
            If calendarItems.Count > 0 Then
                MsgBox dateTimeFormats(i) & vbCrLf & vbCrLf & _
                       "Found: " & calendarItems.Count & " calendar item(s)" & vbCrLf & vbCrLf & _
                       "Subject 1: " & calendarItems(1).subject & vbCrLf & vbCrLf & _
                       "Start time 1: " & Format(calendarItems(1).Start, dateTimeFormats(i)), _
                       vbInformation, _
                       Title:="Date-time format " & i + 1 & "/" & UBound(dateTimeFormats) + 1
            Else
                MsgBox dateTimeFormats(i) & vbCrLf & vbCrLf & _
                       "Found: " & calendarItems.Count & " calendar items", _
                       vbExclamation, _
                       Title:="Date-time format " & i + 1 & "/" & UBound(dateTimeFormats) + 1
            End If
            
        Next
    
    Else
    
        MsgBox "An Outlook Calendar item is not open or selected", vbExclamation
        
    End If
    
End Sub

 

[Yosepht]

Hi John,
apologies I have left it so long to respond. I have re-tested the date/time formats and it was a match for the date format i have been using. How do i remove the body text from the search criteria so that when an exact date and subject match is found for future appointments with a recipient, the code will not re-create that appointment and continue looping through the sheet?

 

[John_w]

How do i remove the body text from the search criteria so that when an exact date and subject match is found for future appointments with a recipient, the code will not re-create that appointment and continue looping through the sheet?

Replace these lines:

    '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

With:

    If Not olCalendarItems Is Nothing Then
        Set Find_Appointment = olCalendarItems(0)
    End If

Assuming there is only 1 appointment which matches the date and subject and you want the first one.

 

[Yosepht]

Hey John,

Very grateful for your response! Ive adapted it to slightly different code below:

Private Function Find_Meeting(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_Meeting = Nothing
   
    'Get calendar items with the specified subject and start time
       
    filter = "[Subject] = " & subject & "' and [Start] = '" & Format(startDateTime, "dd/mm/yyyy hh:nn") & "'"
    Set olCalendarItems = calendarFolder.Items.Restrict(filter)
   
   'See if 1 calendar item match the specified subject and start date
   
    If Not olCalendarItems Is Nothing Then
        Set Find_Meeting = olCalendarItems(0)
    End If
   
End Function

I met a run-time error '440': Array index out of bounds. at Set Find_Meeting = olCalendarItems(0)

 

[John_w]

Try

olCalendarItems(1)

I think the Items is a Collection, so the array index starts at 1.

 

[Yosepht]

It's still displaying the same message, unfortunately.

 

[John_w]

I've discovered that the olCalendarItems collection object is created with a Count of 0 if there are no items in the collection, therefore checking for Not Nothing is incorrect, plus you omitted the leading apostrophe in the subject filter string. Try this modified function:

Private Function Find_Meeting(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_Meeting = Nothing
   
    'Get calendar items with the specified subject and start time
       
    filter = "[Subject] = '" & subject & "' and [Start] = '" & Format(startDateTime, "dd/mm/yyyy hh:nn") & "'"
    Set olCalendarItems = calendarFolder.Items.Restrict(filter)
   
    'See if at least 1 calendar item matches the specified subject and start date
   
    If olCalendarItems.Count > 0 Then
        Set Find_Meeting = olCalendarItems(1)
    End If
   
End Function